任意のExcelの指定した列をインポートする方法

Sub ImportExcelMultipleColumns()
    ' 変数の定義
    Dim fDialog As FileDialog
    Dim filePath As String
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim lastRow As Long
    Dim i As Long
    Dim j As Integer
    Dim targetSheetName As String
    Dim columnList As Variant
    Dim db As DAO.Database
    Dim rs As DAO.Recordset

    ' ファイルダイアログを表示してExcelファイルを選択
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    fDialog.AllowMultiSelect = False
    fDialog.Title = "インポートするExcelファイルを選択してください"
    fDialog.Filters.Add "Excelファイル", "*.xlsx; *.xls", 1

    If fDialog.Show = -1 Then
        filePath = fDialog.SelectedItems(1)
    Else
        MsgBox "ファイルが選択されていません。"
        Exit Sub
    End If

    ' Excelアプリケーションを開く
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Open(filePath)

    ' インポートしたいシート名と列を指定
    targetSheetName = "Sheet1" ' シート名を指定
    columnList = Array("B", "D", "F") ' 任意の列を指定（例："B", "D", "F" 列）

    ' 指定したシートをセット
    On Error Resume Next
    Set xlSheet = xlBook.Worksheets(targetSheetName)
    On Error GoTo 0

    If xlSheet Is Nothing Then
        MsgBox "指定したシートが見つかりません。"
        xlBook.Close False
        xlApp.Quit
        Set xlApp = Nothing
        Exit Sub
    End If

    ' 最終行を取得（最も長い列の最終行を見つける）
    lastRow = xlSheet.Cells(xlSheet.Rows.Count, columnList(0)).End(-4162).Row ' -4162はxlUp

    ' Accessのテーブルにデータをインポート
    Set db = CurrentDb
    Set rs = db.OpenRecordset("YourTableName") ' 取り込み先のテーブル名を指定

    ' 各列のデータをループしてインポート
    For i = 1 To lastRow
        rs.AddNew
        For j = LBound(columnList) To UBound(columnList)
            rs.Fields("Field" & (j + 1)) = xlSheet.Cells(i, columnList(j)).Value ' 各フィールド名を"Field1", "Field2", "Field3"のように指定
        Next j
        rs.Update
    Next i

    ' 終了処理
    rs.Close
    Set rs = Nothing
    xlBook.Close False
    xlApp.Quit
    Set xlApp = Nothing
    MsgBox "インポートが完了しました。"
End Sub