|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Option Explicit
Sub test() '现成的
Dim Cn As Object, Rs As Object, Ca As Object, Tb As Object, d As Object, Sq$, p$, f$, s$(1), i&, j&, k&
Cells.ClearContents
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
s(0) = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
Set Cn = CreateObject("ADODB.Connection")
Cn.Open s(0) & ThisWorkbook.FullName
Set Ca = CreateObject("ADOX.Catalog")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls*")
Do While f <> ""
If f <> ThisWorkbook.Name Then
Ca.ActiveConnection = s(0) & p & f
For Each Tb In Ca.Tables
If Tb.Type = "TABLE" Then
s(1) = Replace(Tb.Name, "'", "")
If Right(s(1), 1) = "$" Then
If InStr(s(1), "2020") Then
Sq = "SELECT * FROM [Excel 12.0;Database=" & p & f & "].[" & s(1) & "A1:b] WHERE LEN(姓名)"
d(Sq) = ""
k = k + 1
If k Mod 49 = 0 Then
i = i + 1: Sq = Join(d.Keys, " UNION ALL "): d.RemoveAll
Set Rs = Cn.Execute(Sq)
If i = 1 Then
For j = 0 To Rs.Fields.Count - 1
Range("A1").Offset(0, j) = Rs.Fields(j).Name
Next
End If
Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
End If
End If
End If
End If
Next
Ca.ActiveConnection = Nothing
End If
f = Dir
Loop
If d.Count Then
Sq = Join(d.Keys, " UNION ALL ")
Set Rs = Cn.Execute(Sq)
If i = 0 Then
For j = 0 To Rs.Fields.Count - 1
Range("A1").Offset(0, j) = Rs.Fields(j).Name
Next
End If
Range("A" & Rows.Count).End(xlUp).Offset(1).CopyFromRecordset Rs
End If
Cn.Close: Set Cn = Nothing: Set Rs = Nothing: Set Tb = Nothing: Set Ca = Nothing: Set d = Nothing
Application.ScreenUpdating = True
Beep
End Sub |
评分
-
1
查看全部评分
-
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2021-2-8 18:18
楼主
