フィールドの値ごとに別のシートへ転記する

フィールドの値ごとに別のシートへ転記する

Sub フィールドの値別にシートへ転記()
Dim myCon As New ADODB.Connection
Dim myRS As New ADODB.Recordset
Dim tmpRS As New ADODB.Recordset
Dim myFile As String, myTbl As String, myFld As String

'対象となるデータベース、テーブル、フィールド
myFile = ThisWorkbook.Path & "\mdb\4-sampleDB.mdb"
myTbl = "アルバイト"
myFld = "所属"

'接続
With myCon
  .Provider = "Microsoft.Jet.OLEDB.4.0;"
  .Open myFile
End With

'指定したテーブルの任意フィールドから重複を取り除いたリストを取得
tmpRS.Open "SELECT DISTINCT " & myFld & " FROM " & myTbl, myCon

'フィールドの見出しとデータリストを転記
With ActiveWorkbook.Worksheets.Add
  .Name = tmpRS.Fields(0).Name
  Range("A1").CopyFromRecordset tmpRS
End With

'取り出し元となるテーブルを取得
With myRS
  .Source = myTbl
  .ActiveConnection = myCon
  .CursorLocation = adUseClient
  .Open
End With

'tmpRSのカーソルを先頭へ戻す
tmpRS.MoveFirst

'取得したりデータ分だけ「フィルタ→転記」を繰り返す
Do Until tmpRS.EOF
  '取得レコードにフィルタをかける
  myRS.Filter = myFld & "='" & tmpRS.Fields(0).Value & "'"
  'シートを追加、シート名を取得フィールド名にして、データ転記
  With ActiveWorkbook.Worksheets.Add
    .Name = tmpRS.Fields(0).Value
    .Range("A1").CopyFromRecordset myRS
  End With
  '重複を除いたリストのデータを次に進める
  tmpRS.MoveNext
Loop

tmpRS.Close: Set tmpRS = Nothing
myRS.Close: Set myRS = Nothing
myCon.Close: Set myCon = Nothing

End Sub

特定フィールドの重複を取り除いた値を返すDISTINCT指定を行ったSELECT命令の結果を受け取るRecordsetオブジェクト(tmpRS)と、任意のテーブル全体を扱うRecordsetオブジェクト(myRS)の2つを用意し、重複を取り除いたリストを元にフィルタをかけ、転記を行う。

データ取得元となる「アルバイト」テーブル

実行結果