|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
Sub limonet()
Dim Cn As Object, StrSQL$, Path$, FileName$, Xrr() As Variant, i%, k%, Dic As Object
Dim C, T, Link$, F, StrField$
Set Cn = CreateObject("Adodb.Connection")
Set Dic = CreateObject("scripting.dictionary")
Link = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
For k = 1 To 2
Path = ThisWorkbook.Path & "\各单位报表\" & k & "月\"
FileName = Dir(Path & "*.xls?")
Do While FileName <> ""
Cn.Open Link & Path & FileName
For Each T In Cn.openschema(20).GetRows(, , "TABLE_NAME")
i = i + 1: ReDim Preserve Xrr(1 To 3, 1 To i)
Xrr(1, i) = FileName
Xrr(2, i) = T
Xrr(3, i) = Path
Next T
For Each C In Cn.openschema(4).GetRows(, , "COLUMN_NAME")
Dic(C) = ""
Next C
Cn.Close
FileName = Dir
Loop
Next k
Range("D1").Resize(1, Dic.Count) = Application.Transpose(Application.Transpose(Dic.keys))
For i = 1 To UBound(Xrr, 2)
Cn.Open Link & Xrr(3, i) & Xrr(1, i)
For Each F In Dic.keys
If Cn.openschema(4, Array(Empty, Empty, Xrr(2, i), F)).EOF Then
StrField = StrField & "," & "Null"
Else
StrField = StrField & "," & F
End If
Next F
StrSQL = StrSQL & " Union All Select '" & Split(Split(Xrr(3, i), "报表\")(1), "月")(0) & "月','" & Xrr(1, i) & "','" & Xrr(2, i) & "'," & Mid(StrField, 2) & " From [Excel 12.0;Database=" & Xrr(3, i) & Xrr(1, i) & "].[" & Xrr(2, i) & "]"
Cn.Close: StrField = ""
Next i
Cn.Open Link & ThisWorkbook.FullName
Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub |
评分
-
2
查看全部评分
-
|
楼主: 月舞苍穹
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-4-23 10:42
楼主