'選擇檔案匯入
Private Sub SelectFile_Click()
        Dim sheet As Excel.Worksheet
        Dim fieldNameArr(), columnNumArr()
        Dim sql As String
        '變數賦值
        fieldNameArr = Array("HUB客戶編號")
        columnNumArr = Array(2)
        sql = "select top 1 * from 交易資訊表"
        '開啟選擇檔案
        Set sheet = HandlerFunction.GetSheetByOpenFile()
        If sheet Is Nothing Then
        Else
            HandlerFunction.InsertToDbBySheet sheet, fieldNameArr, columnNumArr, sql
        End If
End Sub
 

'開啟檔案並返回Sheet
Public Function GetSheetByOpenFile() As Worksheet
    ifilename = Application.GetOpenFilename("Excel(*.xlsx), *.xlsx, Excel(*.xls), *.xls", False)
    
    If ifilename <> "False" Then
        Dim xlApp As Excel.Application
        Dim xlBook As Excel.Workbook
        Set xlApp 
 
= New Excel.Application
        
        Set xlBook = xlApp.Workbooks.Open(ifilename)
        Dim sheet As Excel.Worksheet
    
        Set sheet = xlBook.Sheets(1)
        Set GetSheetByOpenFile = sheet
    Else
        MsgBox "Please select a file first!", vbOKOnly, "Reminder"
        Exit Function
    End If
    
On Error Resume Next
    Set xlBook 
 
= Nothing
    Set xlApp = Nothing
End Function

'根據sheet資料新增到資料庫 filedNameArr插入的欄位名陣列，columnNumArr資料來源Excel中對於的列，必須一一對應
Public Sub InsertToDbBySheet(ByVal sheet As Excel.Worksheet, filedNameArr(), columnNumArr(), ByVal sql As String)
On Error GoTo Get_Err
    Dim arr
    '匯入資料來源
    arr = sheet.Range("A2").CurrentRegion
    
    Dim rst As ADODB.Recordset
    Dim cnn As New ADODB.Connection
    Set rst = New ADODB.Recordset
    cnn.Open AccessConnection
    rst.Open sql, cnn, adOpenKeyset, adLockOptimistic
    cnn.BeginTrans
        
    For i = 2 To UBound(arr) '行數量
        rst.AddNew
        For j = 0 To UBound(filedNameArr)
            rst.Fields(filedNameArr(j)) = arr(i, columnNumArr(j))
        Next j
        rst.Update
    Next i
        
    cnn.CommitTrans '提交事務
                    
    MsgBox "匯入成功！", vbOKOnly, "ReMinder"
    ' clean up
    rst.Close
    cnn.Close
    Set rst = Nothing
    Set cnn = Nothing
    Exit Sub
Get_Err:
    ' clean up
    If Not rst Is Nothing Then
        If rst.State = adStateOpen Then rst.Close
    End If
    Set rst = Nothing
 
    If Not cnn Is Nothing Then
        If cnn.State = adStateOpen Then cnn.Close
    End If
    Set cnn = Nothing
End Sub