【Access VBA】Accessファイル分割

ひとつのAccesファイルを、任意のフィールドの値を基準に複数のAccessファイルに分割します。
（例えば、対象のテーブルの基準フィールドの値が「1」「2」「3」の3種類の場合、その基準値をファイル名にしたうえで、基準フィールドの値がその値のみのレコードを持つファイルに３分割します）

【下記コードの実行方法】
下記のコードをExcelまたはAccessの標準モジュールに貼り付け、実行します。

Option Explicit

Sub Access_File_Divide()

'    必要であればここにエラー処理

    Dim myPath As String
    Dim myAccFile As String
　　Dim trgTblName As String
    Dim trgStFldName As String    
    Dim myFileName As String
    
    myPath = "分割元Accessファイル保存フォルダパス"
    myAccFile = "分割元Accessファイル名"    
    trgTblName = "分割テーブル名"
　　trgStFldName = "分割基準フィールド名"
    myFileName = myPath & myAccFile
    '↑コードをExcelに貼り付ける場合は、上記のパス名等はセルに入力できるようにすれば
    '可変にできる
    
    Dim res As String
    res = MsgBox("Accessファイルを分割しますが、よろしいですか?", vbYesNo)
    If res = vbNo Then Exit Sub
    
    '外部のAccessファイルを指定して接続するため、ADOを使用（参照設定にADOを選択）
    Dim myCon As New ADODB.Connection
    Dim myCmd As New ADODB.Command
    Dim myRS As New ADODB.Recordset
    Dim SQL As String
    
    With myCon
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & myFileName
        .CursorLocation = 3 
　　　　'↑クライアントサイドカーソルに変更 (レコード数をカウントするため)
    End With
    
    SQL = "SELECT " & trgStFldName & " FROM " & trgTblName & _
          " GROUP BY " & trgStFldName & ";"
        
    myRS.Open Source:=SQL, ActiveConnection:=myCon
    
    Dim processCnt_sum As Integer
    processCnt_sum = myRS.RecordCount  'myCon.CursorLocation=3により有効となる    
    
　　'分割基準値をコレクションに格納
    Dim trgStValuesColl As New Collection
    With myRS
        .MoveFirst
        Do Until .EOF
            trgStValuesColl.Add .Fields(trgStFldName).Value
            .MoveNext
        Loop
        .Close: Set myRS = Nothing
    End With
    myCon.Close: Set myCon = Nothing
    
    Dim trgPath As String
    trgPath = "分割後Accessファイル保存フォルダパス"
    
    Dim trgStValue As Variant
    Dim processCnt As Integer
    
    For Each trgStValue In trgStValuesColl
    
        trgStValue = Format(trgStValue, "000")
        Dim trgAcFile As String
        trgAccFile = "分割後Accessファイル名"
        trgAccFile = trgStValue & trgAccFile
        FileCopy myPath & myAccFile, trgPath & trgAcFile
        
        '外部のAccessファイルを指定して接続するため、ADOを使用
        Dim trgCon As New ADODB.Connection
        Dim trgCmd As New ADODB.Command
        Dim trgRS As New ADODB.Recordset
        Dim trgFileName As String
        
        trgFileName = trgPath & trgAccFile
        trgCon.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & trgFileName
        
        'SQL文を使って基準値以外のレコードを削除
        With trgCmd
            .ActiveConnection = trgCon
            .CommandText = "Delete * From " & trgTblName & _
                           " where " & trgStFldName & "<>" & trgStValue & ";"
            .Execute
        End With

        Set trgCmd = Nothing
        trgCon.Close: Set trgCon = Nothing
        
        '分割したAccessファイルを最適化する。        
        Dim Engine As Object
        Set Engine = CreateObject("DAO.DBEngine.120")
        Engine.CompactDatabase trgFileName, trgPath & "（最適後）" & trgAccFile
        Set Engine = Nothing        
        Kill trgFileName  '最適化元ファイルは削除
        Name trgPath & "（最適後）" & trgAccFile As trgFileName   
　　　　'↑最適化後のファイルの名前を元に戻す
        
　　　　'（Excelにコードを貼り付けた場合）ステータスバーに処理状況を表示
        processCnt = processCnt + 1
        Application.StatusBar = "【分割状況】　完了「" & processCnt & _
                                "」/「" & processCnt_sum & "」ファイル中 (" & _
                                Format(processCnt / processCnt_sum, "0%") & ")"
        DoEvents
    
    Next trgStValue
    
    MsgBox "分割処理が終了しました。"
    

    '分割したAccessファイルが保存されたフォルダを開く
    Shell "C:\Windows\Explorer.exe /n, /e," & trgPath, vbNormalFocus

End Sub