VBAでシートからアクセスのテーブルにデータを追加したい。

前提

WorkSheet（wsStart）からAccessDB（test）に不足するデータを追加したい。
それぞれ日付データを取得して突合させ、データを挿入する。

お知らせ

以前の質問を踏襲して、質問しています。（内容は別）
https://teratail.com/questions/1ib3tvqtd06z80

詳細

Excel

日付	数値1	数値2	数値3	数値4
1/1	1000	2000	1000	2000
1/2	1000	2000	1000	2000
1/3	1000	2000	1000	2000
1/4	1000	2000	1000	2000

Access

日付	数値1	数値2	数値3	数値4
1/1	1000	2000	1000	2000
1/2	1000	2000	1000	2000

目的とするAccessDB

日付	数値1	数値2	数値3	数値4
1/1	1000	2000	1000	2000
1/2	1000	2000	1000	2000
1/3	1000	2000	1000	2000
1/4	1000	2000	1000	2000

データタイプはそれぞれ「日付/時刻型」と「数値型」です。

発生している問題・エラーメッセージ

error
1アプリケーション定義およびオブジェクト定義のエラーです。

該当のソースコード

vba
1
2Sub compare_and_copy_date() 
3
4    Dim l As Long, lRow As Long 
5    Dim wsStart As Worksheet: Set wsStart = ThisWorkbook.Sheets("start") 
6    Dim myConn As New ADODB.Connection 
7        myConn.Open ConnectionString:= _ 
8        "Provider=Microsoft.ACE.OLEDB.12.0;" & _ 
9        "Data Source=C:\Users\test.accdb" 
10    Dim myRS As New ADODB.Recordset 
11        myRS.Open Source:="test", ActiveConnection:=myConn, _ 
12        CursorType:=adOpenDynamic 
13
14    '行すべてを表示 
15    wsStart.Rows.Hidden = False 
16
17    'Excelを降順に 
18    Range(Columns(1), Columns(5)).Sort Range("A1"), xlDescending 
19
20    'Excelから[日付]列を取得 
21    lRow = wsStart.Cells(Rows.Count, "A").End(xlUp).Row 
22
23    'Excelデータの最新日付を取得 
24    With myRS 
25        For l = 2 To lRow 
26            .MoveFirst 
27            .Find "日付=#" & Format(wsStart.Cells(l, 1).Value, "yyyy/mm/dd") 'Excelから日付データの取得 
28            If .EOF Then '一致する日付がなければ、行データ追加 
29                .AddNew 
30                !日付.Value = wsStart.Cells(l, 1) 
31                !数値1.Value = wsStart.Cells(l, 2) 
32                !数値2.Value = wsStart.Cells(l, 3) 
33                !数値3.Value = wsStart.Cells(l, 4) 
34                !数値4.Value = wsStart.Cells(l, 5) 
35                .Update 
36            End If 
37        Next l 
38    End With 
39
40    myRS.Close: Set myRS = Nothing 
41    myConn.Close: Set myConn = Nothing 
42
43End Sub
44

試したこと

・.MoveNextなどで調整：インデックス（日付）などを取得していると考えたため。
・取得の確認：Debug.Printでエクセル上の日付データなどが取得できているか確認。
・文法の確認：もう一度見直しや意味があっているのか確認した。

N/A対応

vba
1If myRS.EOF Then '一致する日付がなければ、行データ追加  
2     myRS.AddNew 
3     If IsError(wsStart.Cells(l, 1)) Then 
4          Exit For 
5     Else 
6         myRS!日付.Value = wsStart.Cells(l, 1) 
7     End If 
8     If IsError(wsStart.Cells(l, 2)) Then 
9          Exit For 
10     Else 
11          myRS!始値.Value = wsStart.Cells(l, 6) 
12     End If 
13    myRS.Update  
14Else 
15    Exit For 
16End If

回答1件

質問のコードで、いくつか間違いがあったので修正しました。

修正箇所は２か所です。コメントの※の行です。

vba
1Sub compare_and_copy_date()
2
3    Dim l As Long, lRow As Long
4    Dim wsStart As Worksheet: Set wsStart = ThisWorkbook.Sheets("start")
5    Dim myConn As New ADODB.Connection
6        myConn.Open ConnectionString:= _
7        "Provider=Microsoft.ACE.OLEDB.12.0;" & _
8        "Data Source=C:\test\test.accdb"
9    Dim myRS As New ADODB.Recordset
10        myRS.Open Source:="test", ActiveConnection:=myConn, _
11        CursorType:=adOpenDynamic, LockType:=adLockPessimistic '※LockTypeの設定が必要、省略するとReadOnlyになる
12
13    '行すべてを表示
14    wsStart.Rows.Hidden = False
15
16    'Excelを降順に
17    Range(Columns(1), Columns(5)).Sort Range("A1"), xlDescending
18
19    'Excelから[日付]列を取得
20    lRow = wsStart.Cells(Rows.Count, "A").End(xlUp).Row
21
22    'Excelデータの最新日付を取得
23    With myRS
24        For l = 2 To lRow
25            .MoveFirst
26            .Find "日付=#" & Format(wsStart.Cells(l, 1).Value, "yyyy/mm/dd") & "#" '※ 最後に # が必要
27            If .EOF Then '一致する日付がなければ、行データ追加
28                .AddNew
29                !日付.Value = wsStart.Cells(l, 1)
30                !数値1.Value = wsStart.Cells(l, 2)
31                !数値2.Value = wsStart.Cells(l, 3)
32                !数値3.Value = wsStart.Cells(l, 4)
33                !数値4.Value = wsStart.Cells(l, 5)
34                .Update
35            End If
36        Next l
37    End With
38
39    myRS.Close: Set myRS = Nothing
40    myConn.Close: Set myConn = Nothing
41
42End Sub

こちらで作成したサンプルでは、上記のコードで正常にAccessのテーブルにデータが追加されました。

追記セルのn/aエラー対策

下記のように修正してください。

vba
1            If .EOF Then '一致する日付がなければ、行データ追加
2                .AddNew
3                If Not IsError(wsStart.Cells(l, 1)) Then !日付.Value = wsStart.Cells(l, 1)
4                If Not IsError(wsStart.Cells(l, 2)) Then !数値1.Value = wsStart.Cells(l, 2)
5                If Not IsError(wsStart.Cells(l, 3)) Then !数値2.Value = wsStart.Cells(l, 3)
6                If Not IsError(wsStart.Cells(l, 4)) Then !数値3.Value = wsStart.Cells(l, 4)
7                If Not IsError(wsStart.Cells(l, 5)) Then !数値4.Value = wsStart.Cells(l, 5)
8                .Update
9            End If

いちおうすべての項目にエラーチェックを付けましたが、式を設定してないセル(エラーになることははないセル)はなくてもいいです。

投稿2022/12/06 12:19

編集2022/12/08 03:58

hatena19

総合スコア32005

回答へのコメント

Kazuhiro-ch

2022/12/07 05:21

ありがとうございます。試してみたところうまく動きました。あと1点、N/Aなどのエラーがあったときに、そのセルはスキップして次に進むようにしたいです。上記にコードを載せたのですが、動きません。（エラーは出ませんが、転記されない）どのようにするのが良いのでしょうか？ご教授いただけると幸いです。

hatena19

2022/12/08 01:33

> そのセルはスキップして次に進むとは具体的にどうしたいのでしょうか。１．エラーセルと対応するフィールドは未入力にする。２．エラーセルがあったらその行のデータは入力せずに、次の行に進む。３．エラーセルがあったら、その時点で転記処理を終了する。上記の３つのうちどれでしょう。提示のコードだと Exit For してますので、３．の処理になってます。

Kazuhiro-ch

2022/12/08 02:48

１．エラーセルと対応するフィールドは未入力にする。です。 Exit Forはその時点で転記処理を終了する。という意味になってしまうのですね。知りませんでした。現在のコードでは、エラーの有無に関わらず、転記されません。

Kazuhiro-ch

2022/12/08 04:34

ありがとうございます。ただ、これだとエラーのところが0になってしまうようなのですが、それを回避する方法はありますか？

hatena19

2022/12/08 04:54

テーブルのフィールドの規定値プロパティが０になっているためだと思われます。これを削除してから試してください。

Kazuhiro-ch

2022/12/10 05:56

ありがとうございます。確かにそのようでした。ちなみに幾つかのテーブルに流用する場合、都度テーブルごとに規定値を変更する必要がありますか？もしくはマクロで規定値をゼロにする→コードをうごかすなどできますか？

hatena19

2022/12/10 11:14

If IsError(wsStart.Cells(l, 1)) Then !日付.Value = Null Else !日付.Value = wsStart.Cells(l, 1) とすればいいでしょう。本来はテーブル設計の段階でどうるすか決めておくべきことです。そうしないとNullと0が混在することになり、後でいろいろ面倒です。