要求：提取同一文件夹两个文件中各单位的汇总数，填到C列和D列，并计算差额。

lizequn1976 · 发表于 2024-3-29 11:21

要求：用vba提取同一文件夹两个文件中各单位的汇总数，填到C列和D列，并计算差额。谢谢！

LIUZHU · 发表于 2024-3-29 11:30

这个问题用公式不简单多了，需要VBA？

沈默00 · 发表于 2024-3-29 11:30

4001和单位1有什么关联？？

yanglinzi · 发表于 2024-3-29 12:08

请测试。。

yanglinzi · 发表于 2024-3-29 12:09

Sub 汇总找差数()
Dim arr, brr, i, j, d, fso, p
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Set fso = CreateObject("scripting.filesystemobject")
p = ThisWorkbook.Path & ""
brr = Sheet1.UsedRange
For Each f In fso.getfolder(p).Files
If InStr(f.Name, "汇总") = 0 Then
Debug.Print f.Name
Set wb = Workbooks.Open(f)
Set sh = wb.Sheets(1)
arr = sh.UsedRange
wb.Close False
For i = 2 To UBound(arr)
If arr(1, 1) = "单位编码" Then
s = arr(i, 1)
d(s) = d(s) + arr(i, 2)
Else
s = arr(i, 1)
d1(s) = d1(s) + arr(i, 2)
End If
Next
End If
Next
For j = 2 To UBound(brr)
s = brr(j, 1)
ss = brr(j, 2)
If d.exists(s) Then
brr(j, 3) = d(s)
End If
If d1.exists(ss) Then
brr(j, 4) = d1(ss)
End If
brr(j, 5) = brr(j, 3) - brr(j, 4)
Next
Sheet1.UsedRange.Offset(1, 2).ClearContents
Sheet1.UsedRange = brr
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

复制代码

ykcbf1100 · 发表于 2024-3-29 19:36

附件供参考。。。

ykcbf1100 · 发表于 2024-3-29 19:37

参与一下。。。

Sub ykcbf() '//2024.3.29
Set fso = CreateObject("scripting.filesystemobject")
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("Sheet1")
p = ThisWorkbook.Path & ""
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = Replace(fso.GetBaseName(f), "数据", "")
Set wb = Workbooks.Open(f, 0)
With wb.Sheets("Sheet1")
arr = .UsedRange
wb.Close False
End With
For i = 2 To UBound(arr)
s = arr(i, 1) & "|" & fn
d(s) = d(s) + arr(i, 2)
Next
End If
End If
Next f
With sh
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 5)
For i = 2 To UBound(arr)
s = arr(i, 1) & "|" & Replace(arr(1, 3), "合计金额", "")
If d.exists(s) Then
arr(i, 3) = d(s)
End If
s = arr(i, 2) & "|" & Replace(arr(1, 4), "合计金额", "")
If d.exists(s) Then
arr(i, 4) = d(s)
End If
arr(i, 5) = arr(i, 4) - arr(i, 3)
Next
.[a1].Resize(1, 5).Interior.Color = 49407
With .[a1].Resize(r, 5)
.Value = arr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter '//列居中
.VerticalAlignment = xlCenter
End With
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

limonet · 发表于 2024-3-29 23:07

关键字：Cn.OpenSchema+LEFT JOIN

limonet · 发表于 2024-3-29 23:08

Sub limonet()
Dim Cn As Object, StrSQL$, StrSQL1$, Path$, FileName$, Arr As Variant
Arr = Range("A1:B1")
Set Cn = CreateObject("ADODB.Connection")
Path = ThisWorkbook.Path & "\"
FileName = Dir(Path & "*.xls?")
StrSQL = "Select * From [Sheet1$A:B]"
Do While FileName <> ""
      If FileName <> "汇总表.xlsm" Then
         Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Path & FileName
         If Cn.OpenSchema(4, Array(Empty, Empty, Empty, "单位编码")).EOF Then
            StrSQL = "Select a.*,b.金额 From (" & StrSQL & ")a Left Join (Select 单位,Sum(金额) As 金额 From [Excel 12.0;Database=" & Path & FileName & "].[Sheet1$] Group By 单位)b On a.单位=b.单位"
         Else
            StrSQL = "Select a.*,b.金额 From (" & StrSQL & ")a Left Join (Select 单位编码,Sum(金额) As 金额 From [Excel 12.0;Database=" & Path & FileName & "].[Sheet1$] Group By 单位编码)b On a.单位编码=b.单位编码"
         End If
         Cn.Close
      End If
      FileName = Dir
Loop
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Range("A2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

		自动登录	找回密码
密码			免费注册

[求助] 要求：提取同一文件夹两个文件中各单位的汇总数，填到C列和D列，并计算差额。

评分

评分