Sub InsertToDataBase()

    Dim DataPath As String
    Dim SQL As String
    Const DataName As String = "yunying.mdb"
    Const TableName As String = "關鍵詞效果分析"

    DataPath = ThisWorkbook.Path & "\" & DataName

    Dim Rng As Range
    Dim Arr As Variant
    Dim EndRow As Long
    Dim Fileds As String
    Dim Values As String
    
    With ThisWorkbook.Worksheets(1)
        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row
        Set Rng = .Range("A1:R" & EndRow)
        Arr = Rng.Value

        For i = 2 To Rng.Rows.Count
            Fileds = ""
            Values = ""
            For j = 1 To 6
                Fileds = Fileds & Arr(1, j) & ","
                Values = Values & "‘" & Arr(i, j) & "‘," ‘數值轉為文本
            Next j

            For j = 7 To Rng.Columns.Count
                Fileds = Fileds & Arr(1, j) & ","
                Values = Values & Arr(i, j) & ","
            Next j

            Fileds = Left(Fileds, Len(Fileds) - 1)
            Values = Left(Values, Len(Values) - 1)

            SQL = "INSERT INTO " & TableName & " (" & Fileds & ") VALUES(" & Values & ")"

            Debug.Print SQL
            CnnRunSQL DataPath, SQL

            ‘If i = 2 Then Exit Sub
        Next i
    End With
    Set Rng = Nothing
End Sub
Sub CnnRunSQL(ByVal DataPath As String, ByVal SQL As String)
‘對象變量聲明
    Dim CNN As Object
    Dim RS As Object
    ‘數據庫引擎——Excel作為數據源
    Const DATA_ENGINE As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
    ‘創建ADO Connection 連接器 實例
    Set CNN = CreateObject("ADODB.Connection")
    ‘ On Error Resume Next
    ‘創建 ADO RecordSet  記錄集 實例
    ‘Set RS = CreateObject("ADODB.RecordSet")
    ‘連接數據源
    CNN.Open DATA_ENGINE & DataPath
    ‘執行查詢 返回記錄集
    
     CNN.Execute (SQL)
    ‘RS.Open SQL, CNN, 1, 1
    ‘關閉記錄集
    ‘RS.Close
    ‘關閉連接器
    CNN.Close
    ‘釋放對象
    Set RS = Nothing
    Set CNN = Nothing
End Sub

20161208xlVBA工作表數據導入Access