Option Explicit
Dim i As Long, j As Long, k As Long, l As Long, m As Long
Sub xls_to_ac()
On Error GoTo endrtn
Dim MyDatabase As Database
Dim rst As Recordset
Dim MyFile As String, strSQL As String
Dim stra(3) As String
    MyFile = "C:\My Documents\xls_to_mdb.mdb"
    If Dir(MyFile) = "" Then
        MsgBox "C:\My Documents\xls_to_mdb.mdb not found"
        Exit Sub
    End If
    Set MyDatabase = Workspaces(0).OpenDatabase(MyFile)
    '
    'Date Delete
    '
    strSQL = "DELETE FROM table1 ;"
    MyDatabase.Execute strSQL
    Application.StatusBar = "読み込み中・・・"
    For i = 1 To 3
        Workbooks.Open Filename:="C:\My Documents\test_data_a000" & i & ".xls"
        l = 6
        For k = 1 To 3
            stra(k) = Lf_conv(Trim(Worksheets(1).Cells(l, 2)))
            l = l + 2
        Next k
        '
        'Data Insert
        '
        strSQL = "INSERT INTO table1 (xls,msg1,msg2,msg3) VALUES ('" & _
        "a000" & i & "','" & stra(1) & "','" & stra(2) & "','" & stra(3) & "');"
        MyDatabase.Execute strSQL
        ActiveWindow.Close SAVECHANGES:=False
    Next i
    '
    'Fetch
    '
    Cells.Select
    Selection.ClearContents
    m = 1
    strSQL = "SELECT * FROM table1;"
    Set rst = MyDatabase.OpenRecordset(strSQL)
    Do Until rst.EOF
        With rst
            Worksheets(1).Cells(m, 1) = !xls
            m = m + 1
            rst.MoveNext
        End With
    Loop
    Worksheets(1).Cells(1, 1).Select
    rst.Close
    Set rst = Nothing
    MyDatabase.Close
    Set MyDatabase = Nothing
    Application.StatusBar = ""
    MsgBox "end"
endrtn:
    Application.Cursor = xlNormal
    Application.ScreenUpdating = True
End Sub
'エクセルでの改行はvbLfのみなのでアクセスに書き込む時は
'改行があればvbCrLfに変更する。
Function Lf_conv(strwk As String) As String
On Error GoTo Err_1
    Lf_conv = ""
    For j = 1 To Len(strwk)
        If Mid(strwk, j, 1) = vbLf Then
            Lf_conv = Lf_conv & vbCrLf
        Else
            Lf_conv = Lf_conv & Mid(strwk, j, 1)
        End If
    Next j
Exit Function
Err_1:
    MsgBox Err.Description, vbCritical
End Function