EXCEL VBA根据表数据写入数据库中

Option Explicit

'https://club.excelhome.net/thread-1687531-1-1.html

'Sub UpdateAccess()
'  Const adStateOpen = 1
'  Dim vData, i As Variant, j As Long
'  Dim AccessTable As String, ExcelTable As String, ExcelFile As String, AccessFile As String, SQL(2) As String
'  AccessTable = "Sheet1"
'  ExcelFile = ThisWorkbook.FullName
'  With ActiveSheet
'    vData = .Range("A1").CurrentRegion.Rows(1).Value
'    ExcelTable = .Name & "$" & .Range("A1").CurrentRegion.Address(0, 0)
'    AccessFile = "\\192.168.22.122\模版\数据源.accdb"
'  End With
'  For j = 1 To UBound(vData, 2)
'    If j < 5 Then
'      SQL(0) = SQL(0) & " AND a.[" & vData(1, j) & "]=b.[" & vData(1, j) & "]"
'    Else
'      SQL(1) = SQL(1) & ",a.[" & vData(1, j) & "]=b.[" & vData(1, j) & "]"
'    End If
'  Next
'  SQL(0) = Mid(SQL(0), 6): SQL(1) = Mid(SQL(1), 2)
'  Dim Conn As Object: Set Conn = CreateObject("ADODB.Connection")
'  'Dim rs As Object: Set rs = CreateObject("ADODB.Recordset")
'  On Error Resume Next
'  Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
'  SQL(2) = "UPDATE " & AccessTable & " a,[Excel 12.0;IMEX=0;Database=" & ExcelFile & "].[" & ExcelTable & "] b SET " & SQL(1) & " WHERE " & SQL(0)
'  Conn.Execute SQL(2)
'  If Conn.State = adStateOpen Then Conn.Close
'  Set Conn = Nothing
'  If Err.Number = 0 Then MsgBox "哇噻！一帆风顺,上传成功……", 64 Else MsgBox "^_^ 卧槽！此路不畅,未能上传……": Err.Clear
'End Sub

Sub IntoAccess()

  Const adStateOpen As Long = 1
  Const adSchemaTables As Long = 20
  Dim vFields, SQL As String
  Dim AccessFile As String, AccessTable As String
  Dim ExcelTable As String, ExcelFile As String, Flag As Boolean
  
  AccessFile = "\\192.168.22.122\模版\数据源.accdb"   '  模版 文件夹要共享，要有足够的权限
  AccessTable = "Sheet1"
  ExcelFile = ThisWorkbook.FullName
  With ActiveSheet
    ExcelTable = .Name & "$" & .Range("A1").CurrentRegion.Address(0, 0)
    vFields = Application.Rept(.Range("A1").CurrentRegion.Rows(1).Value, 1)
  End With
  
  Dim Conn As Object
  Set Conn = CreateObject("ADODB.Connection")
  Dim rs As Object
  Set rs = CreateObject("ADODB.Recordset")
  
  Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & AccessFile
  Set rs = Conn.OpenSchema(adSchemaTables)
  Do Until rs.EOF
    If rs!TABLE_TYPE = "TABLE" Then
      If rs!TABLE_NAME = AccessTable Then Flag = Not Flag: Exit Do
    End If
    rs.MoveNext
  Loop
  If rs.State = adStateOpen Then rs.Close
  
  If Not Flag Then
    SQL = "SELECT * INTO " & AccessTable & " FROM [Excel 12.0;Database=" & ExcelFile & "].[" & ExcelTable & "]"
    Conn.Execute SQL
  Else
    Dim j As Long, subSQL(1) As String
    For j = 1 To UBound(vFields)
      If j < 5 Then
        subSQL(0) = subSQL(0) & " AND a.[" & vFields(j) & "]=b.[" & vFields(j) & "]"
      Else
        subSQL(1) = subSQL(1) & ",a.[" & vFields(j) & "]=b.[" & vFields(j) & "]"
      End If
    Next
    subSQL(0) = Mid(subSQL(0), 6): subSQL(1) = Mid(subSQL(1), 2)
    
    UpdateAddRecords Conn, rs, AccessTable, ExcelFile, ExcelTable, subSQL
    
  End If
  
  If rs.State = adStateOpen Then rs.Close
  Set rs = Nothing
  If Conn.State = adStateOpen Then Conn.Close
  Set Conn = Nothing
  
  If Not Flag Then MsgBox Cells(Rows.Count, 1).End(xlUp).Row - 1 & " 行数据已经新添到数据库！", 64, "添加成功"
End Sub

Function UpdateAddRecords(Conn As Object, rs As Object, AccessTable As String, ExcelFile As String, ExcelTable As String, subSQL() As String)
  On Error GoTo EndLine0
  
  Const adOpenKeyset As Long = 1
  Const adLockOptimistic As Long = 3
  Dim SQL As String, vCount As Variant
  
  SQL = "UPDATE " & AccessTable & " a,[Excel 12.0;IMEX=0;Database=" & ExcelFile & "].[" & ExcelTable & "] b SET " & subSQL(1) & " WHERE " & subSQL(0)
  Conn.Execute SQL                                       '不判断，更新可能存在的“考号”等
  '下为生成数据库不存在记录的SQL语句
  SQL = "SELECT a.* FROM [Excel 12.0;Database=" & ExcelFile & "].[" & ExcelTable & "] a LEFT JOIN " & AccessTable & " b ON " & subSQL(0) & " WHERE b.日期 IS NULL"
  rs.Open SQL, Conn, adOpenKeyset, adLockOptimistic
  vCount = rs.RecordCount
  If vCount > 0 Then                                     '如果工作表中含有数据库不存在记录
    SQL = "INSERT INTO " & AccessTable & Chr(32) & SQL   '插入新记录SQL语句
    Conn.Execute SQL
    MsgBox vCount & " 行数据添加，原有的已更新成功！", vbInformation, "Data Added Successfully!"
  Else
    MsgBox "数据存在，木有添加，更新成功！", vbInformation, "Data Updated Successfully!"
  End If
  Exit Function
EndLine0:
  MsgBox Err.Description, , "Error Message Report!"
End Function