|
|
加个判断：
Sub 从Excel工作表中向数据表添加或更新纪录() '字典合并同项
Dim Fso As Object, File As Object, cnn As Object, rs As Object, rst As Object, SQL$, myTable$, sh$, d As Object, arr, i&, k, t
Set d = CreateObject("scripting.dictionary")
Set cnn = CreateObject("ADODB.Connection")
myTable = "不合格汇总"
Set Fso = CreateObject("Scripting.FileSystemObject")
For Each File In Fso.GetFolder(ThisWorkbook.Path).Files
If File.Name Like "未合格日报*.xlsx" Then
Set cnn = CreateObject("adodb.connection")
cnn.Open "provider=microsoft.Ace.oledb.12.0;extended properties=excel 12.0;data source=" & File
Set rs = cnn.OpenSchema(20)
Do Until rs.EOF
If rs.Fields("TABLE_TYPE") = "TABLE" Then
sh = Replace(rs("TABLE_NAME").Value, "'", "")
If Right(sh, 1) = "$" Then
SQL = "SELECT 生产号,备注 FROM [" & sh & "]"
Set rst = cnn.Execute(SQL)
If Not rst.EOF Then
arr = rst.GetRows
For i = 0 To UBound(arr, 2)
If Not d.Exists(arr(0, i)) Then
d(arr(0, i)) = arr(1, i)
Else
If InStr("," & d(arr(0, i)) & ",", "," & arr(1, 0) & ",") = 0 Then d(arr(0, i)) = d(arr(0, i)) & "," & arr(1, i)
End If
Next
End If
End If
End If
rs.MoveNext
Loop
End If
Next
If d.Count Then
k = d.keys
t = d.items
Set cnn = CreateObject("adodb.connection")
cnn.Open "Provider=Microsoft.Ace.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\data.accdb"
For i = 0 To d.Count - 1
SQL = "SELECT * FROM " & myTable & " WHERE [ACC Number]='" & k(i) & "'"
Set rs = CreateObject("ADODB.Recordset")
rs.Open SQL, cnn, 1, 3
If rs.RecordCount = 0 Then
rs.AddNew
rs.Fields(0) = k(i)
rs.Fields(1) = t(i)
Else
rs.Fields(1) = t(i)
End If
rs.Update
Next
MsgBox "纪录添加更新成功。", vbInformation, "添加纪录更新"
rs.Close
rst.Close
cnn.Close
Set rs = Nothing
Set rst = Nothing
Else
MsgBox "没有发现数据源。", vbInformation, "添加纪录更新记录失败"
End If
Set cnn = Nothing
Set Fso = Nothing
End Sub
|
|
楼主: Bettyexcel
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2015-11-19 16:54
楼主
