Microsoft Access 掲示板

提示の Dataプロシージャは1件のレコードを追加するコードですね。
100件のレコードの追加は、Dataプロシージャをループで呼び出しているのだと思いますが、
そのコードも提示してもらえますか。

※質問は編集できますので、質問に追記してください。

いや、違うのです。
販売データを作る、EXCELL VBAの専用エディタがあるのですが、
販売待ちのデータは、excellのシートに保存してあります。

多くても、300件以上になることはありません。
そこで、状況を見ながら数量指定(nl)をして、本番のデータに変換して販売を開始します。

Worksheets("出品ファイル").Activate
 For i = 2 To nl
で、データを拾っていきます。
この過程で、画像をコピーしたり、フォルダを作ったりという作業を並行して行っているので
先走りして、追加が終わらないうちに、次のデータの処理を始めてしまうのが、原因だろうと予想しております。

Declare PtrSafe Function GetInputState Lib "USER32" () As Long
と
SyuppinData (i)
 If GetInputState() Then DoEvents
で、先走りしないようにはしていますが、
経験上、あまり効果は見込めません。

とりあえず、追加の工程は、For iを別口で作って最初に処理するようにはしました。
EXCELLからACCESSは、思っていた以上に負担がかかっているようなので
処理結果を確認して、正しく処理できるまで続けるコードは利用したいと思っております。

Worksheets("出品ファイル").Activate
 For i = 2 To nl
で、データを拾っていきます。

この For Next内で DataプロシージャをCallしているということでよすね。
このFor Next内で何をしているか知りたいのです。

というのは、

この過程で、画像をコピーしたり、フォルダを作ったりという作業を並行して行っているので
先走りして、追加が終わらないうちに、次のデータの処理を始めてしまうのが、原因だろうと予想しております。

まずはその予想があっているのかどうか、
VBAはシングルタスクなのでVBAの標準のコマンドならそのようなことは通常はおこらないはず、外部コマンドを使っているか、なにか特別なことをしているのか、
その辺を確認したいのです。

追加に失敗したら、追加されるまで処理を繰り返すというのは対症療法的な解決法です。できれば、根本の原因を特定して、そちらで解決できる方法がないかさぐるのが先決だと考えます。

その解決法がどうしてもないのなら、次善策として対症療法的解決法をとるというようにすべきと考えます。

とりあえず現状のコードで修正したほうかいいと思われるところを指摘しておきます。

    Worksheets("出品ファイル").Activate
    Num1 = 1 '回数入力
    Num2 = Cells(i, 6).Value '特価取得
    ・・・

シートをActivateしてアクティブなシートを対象に処理をしていますが、アクティブシートを前提にするとバグのもとになります。
シートを変数に格納してそれを対象にするか、With ステートメントで明示的に対象シートを指定するほうが確実、安全なコードになります。

    Dim ws As WorkSheet
    Set ws = ThisWorkbook.Worksheets("出品ファイル")
    Num1 = 1 '回数入力
    Num2 = ws.Cells(i, 6).Value '特価取得
    ・・・

    With ThisWorkbook.Worksheets("出品ファイル")
        Num1 = 1 '回数入力
        Num2 = .Cells(i, 6).Value '特価取得
    ・・・
    End With

次に、下記のコードについて

Function AddDB(ByVal Tn As String, ByVal Fn As String, ByVal Fd As String) As ADODB.Recordset

Functionの戻り値を Recordset にしてますが、INSERT INTO文は Recordset を返しません。テーブルへのデータを追加するだけです。
Function内で戻り値も設定していないので無意味なものになっています。
また、この関数内で、
Set adoCn = CreateObject("ADODB.Connection")
とADODBコネクションを生成してますが、
Closeしてません。使用後は明示的にCloseすべきです。

さらに、100件くらいのレコードを追加する場合、
100回ADODBコネクションを生成することになりますが、
無駄なことです。
100件のレコードを追加するなら、コネクションを最初に1回生成してOpenして、
続けて100回追加して、最後にCloseするという処理にすると効率的です。

この部分だけでも、かなりの量になりますが、大丈夫でしょうか？
添付ファイルで送れれば、ファイルを送りますが。
見ていただいて、問題個所を公開していただいても構いません。

コードの詳細をアップするのは、連絡をお待ちしてからにしますが、
シートを変数に、格納してそれを対象にするように変更します。
かなり、改善されるような気がします。

あと、初歩的な質問で申し訳ないのですが、
コネクションを最初に1回生成してOpenして、
続けて100回追加して、最後にCloseするには、以下のようなプロシージャを作っておいて

Sub AdoOpen()
    strFileName = "データ.accdb" 'データベースのファイル名

    Set adoCn = CreateObject("ADODB.Connection") 'ADODBコネクションオブジェクトを作成
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\tasukaru\Desktop\VBA\出品データ用\access\" & strFileName & ";" 'Accessファイルに接続
End Sub

　　AdoOpen

    Set ws = ThisWorkbook.Worksheets("出品ファイル")
    Num1 = 1 '回数入力
    Num2 = ws.Cells(i, 6).Value '特価取得
    ・・・

　　adoCn.Close

で、良いのでしょうか？

コネクションを最初に1回生成してOpenして、
続けて100回追加して、最後にCloseするには、以下のようなプロシージャを作っておいて

AdoOpen() というようにプロシージャを分けるなら、下記のような設計がいいかな。

Sub AdoOpen(FileName As String, adoCn As ADODB.Connection)
    Dim FilePath As String
    FilePath = "C:\Users\tasukaru\Desktop\VBA\出品データ用\access\" & FileName

    Set adoCn = CreateObject("ADODB.Connection") 'ADODBコネクションオブジェクトを作成
    adoCn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & FilePath & ";" 'Accessファイルに接続
End Sub

Function AddDB(ByVal Tn As String, ByVal Fn As String, ByVal Fd As String, ByRef adoCn As ADODB.Connection) As Boolean
    Dim strSQL As String
    AddDB = True
    
    On Error GoTo errTrap
    strSQL = "INSERT " & "INTO " & Tn & Fn & " VALUES" & "(" & Fd & ")"
    'Debug.Print strSQL
    adoCn.Execute strSQL 'SQLを実行して対象を追加
  
    Exit Function
errTrap:
    AddDB = False
    MsgBox Err.Number & ": " & Err.Description
End Function

Public Sub Proc()
    Dim adoCn As ADODB.Connection
    AdoOpen "データ.accdb", adoCn
    
    Tn = "・・・"
    Fn = "・・・"
    Fd = "・・・"
    
    If AddDB(Tn, Fn, Fd, adoCn) = False Then
        MsgBox "データ追加に失敗しました。"
    End If

    adoCn.Close
    Set adoCn = Nothing
End Sub

AddDBでデータ追加に失敗するとエラートラップでエラーメッセージを表示するようにしてますので、
それで失敗の原因が特定できると思います。

すみません、下の部分が分かりません
下の2つのプロシージャは、Sub Dataから呼び出すことになると思いますが
adoCnは、どう定義して呼び出したらよいのでしょうか？

Sub AdoOpen(FileName As String, adoCn As ADODB.Connection)

Function AddDB(ByVal Tn As String, ByVal Fn As String, ByVal Fd As String, ByRef adoCn As ADODB.Connection) As Boolean

最初の、Function AddDBの中に、Sub Dataのコードを書いて処理すれば
コネクションを1回だけ開いて、連続してアップできますが、
分けた方が、汎用性のあるコードになるので、使えるようにしたいと思います。

ちなみに、

私のコードの Sub Proc が Sub Data に相当しますので、参考にしてください。

なんとなく、でも確実にわかってきました。
If AddDB(Tn, Fn, Fd, adoCn) なんですね。
ありがとうございます。

なぜ、他のモジュールから呼び出せるPublicなのか、
分からないので調べてみます。

どうしても、謎だったら明日、質問させていただきます。

なぜ、他のモジュールから呼び出せるPublicなのか、
分からないので調べてみます。

それに関しては、深い意味はないです。他から呼び出す必要がないなら、Private で問題ないです。

というか、AdoOpen AddDB を汎用化して、他で使いまわすなら、こちらの方を標準モジュールでPublicにしておいた方がいいですね。

報告します。
Set ws = Workbooks("auctions_ado.xlsm").Worksheets("sheet1")
を
Set ws = ThisWorkbook.Worksheets("sheet1")
に変更したところ、エラーが出なくなりました。