python
复制代码
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
