|
Option Explicit
Sub test()
Dim d As Object, cnn As Object, rst As Object, fil, sql$, ar
Dim i&, j&, k&, n&, s$, t$, st$, x&, y&
Application.ScreenUpdating = False
Sheet1.Activate
[g1].Resize(789, 123).ClearContents
ar = [a1].CurrentRegion.Resize(, 5)
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(ar)
s = ""
For j = 1 To UBound(ar, 2)
s = s & "," & ar(i, j)
Next
d(Mid(s, 2)) = Array(i, 7)
Next
Set cnn = CreateObject("Adodb.Connection")
Set rst = CreateObject("Adodb.Recordset")
For Each fil In CreateObject("Scripting.FilesyStemObject").GetFolder(ThisWorkbook.Path).Files
If fil.Name <> ThisWorkbook.Name And InStr(fil.Name, "~$") = 0 Then
t = Split(fil.Name, ".")(0) & ","
n = n + 1
If n = 1 Then
cnn.Open "provider=microsoft.ace.oledb.12.0;extended properties='Excel 12.0;hdr=no';data source=" & fil
Else
st = "[Excel 12.0;hdr=no;Database=" & fil & ";]."
End If
sql = "SELECT * FROM " & st & "[Sheet1$]"
rst.Open sql, cnn, 1, 3
ar = rst.GetRows
For i = 0 To UBound(ar, 2) Step 5
For j = 0 To UBound(ar)
s = ""
For k = i To i + 2
s = s & "," & ar(j, k)
Next
s = t & s
If d.exists(s) Then
y = d(s)(0)
x = d(s)(1)
Cells(y, x) = Cells(i + 1, j + 1).Address(0, 0)
d(s) = Array(y, x + 1)
End If
Next
Next
If rst.State = 1 Then rst.Close
End If
Next
cnn.Close
Set cnn = Nothing
Set rst = Nothing
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!", 64
End Sub |
评分
-
3
查看全部评分
-
|