|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Sub test()
Dim br, i&, j&, k&, s$, t$
Dim d As Object, Cn As Object, Rs As Object, Sq$, sfd, f
Set d = CreateObject("Scripting.Dictionary")
Sheets(1).Activate
br = [a1].CurrentRegion.Resize(2)
For j = 5 To UBound(br, 2)
If br(1, j) = "" Then br(1, j) = br(1, j - 1)
d(br(1, j) & br(2, j)) = j
Next
ReDim ar(1 To 2000, 1 To j - 1)
Set Cn = CreateObject("ADODB.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=no';Data Source=" & ThisWorkbook.FullName
For Each sfd In CreateObject("Scripting.FileSystemObject").GetFolder(ThisWorkbook.Path).SubFolders
For Each f In sfd.Files
If InStr(f, "社会保险费分险种申报汇总表_") Then
k = k + 1
Sq = "SELECT * FROM [Excel 12.0;hdr=no;Database=" & f & "].[$a5:g]"
br = Cn.Execute(Sq).GetRows
ar(k, 1) = k
ar(k, 2) = br(1, 0)
ar(k, 3) = br(5, 0)
For j = 4 To UBound(br, 2)
s = br(1, j) & "-" & br(2, j)
If Not IsNull(br(3, j)) Then ar(k, 4) = ar(k, 4) + Val(br(3, j))
For i = 4 To UBound(br)
t = s & br(i, 2)
If d.Exists(t) Then ar(k, d(t)) = br(i, j)
Next
Next
End If
Next
Next
[a1].CurrentRegion.Offset(2).Clear
If k Then [a3].Resize(k, 31) = ar Else MsgBox "没有数据"
[a1].CurrentRegion.Borders.LineStyle = 1
Cn.Close
Set Cn = Nothing
Set d = Nothing
End Sub |
评分
-
2
查看全部评分
-
|