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

lizequn1976

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

LIUZHU

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

沈默00

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

yanglinzi

请测试。。

yanglinzi

1. Sub 汇总找差数()
   
2. Dim arr, brr, i, j, d, fso, p
   
3. Application.DisplayAlerts = False
   
4. Application.ScreenUpdating = False
   
5. Set d = CreateObject("scripting.dictionary")
   
6. Set d1 = CreateObject("scripting.dictionary")
   
7. Set fso = CreateObject("scripting.filesystemobject")
   
8. p = ThisWorkbook.Path & ""
   
9. brr = Sheet1.UsedRange
   
10. For Each f In fso.getfolder(p).Files
    
11.     If InStr(f.Name, "汇总") = 0 Then
    
12.         Debug.Print f.Name
    
13.         Set wb = Workbooks.Open(f)
    
14.         Set sh = wb.Sheets(1)
    
15.         arr = sh.UsedRange
    
16.         wb.Close False
    
17.         For i = 2 To UBound(arr)
    
18.             If arr(1, 1) = "单位编码" Then
    
19.                 s = arr(i, 1)
    
20.                 d(s) = d(s) + arr(i, 2)
    
21.             Else
    
22.                 s = arr(i, 1)
    
23.                 d1(s) = d1(s) + arr(i, 2)
    
24.             End If
    
25.         Next
    
26.     End If
    
27. Next
    
28. For j = 2 To UBound(brr)
    
29.     s = brr(j, 1)
    
30.     ss = brr(j, 2)
    
31.     If d.exists(s) Then
    
32.         brr(j, 3) = d(s)
    
33.     End If
    
34.     If d1.exists(ss) Then
    
35.         brr(j, 4) = d1(ss)
    
36.     End If
    
37.     brr(j, 5) = brr(j, 3) - brr(j, 4)
    
38. Next
    
39. Sheet1.UsedRange.Offset(1, 2).ClearContents
    
40. Sheet1.UsedRange = brr
    
41. Application.DisplayAlerts = True
    
42. Application.ScreenUpdating = True
    
43. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.3.29
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If f.Name Like "*.xls" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 fn = Replace(fso.GetBaseName(f), "数据", "")
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 With wb.Sheets("Sheet1")
    
13.                     arr = .UsedRange
    
14.                     wb.Close False
    
15.                 End With
    
16.                 For i = 2 To UBound(arr)
    
17.                     s = arr(i, 1) & "|" & fn
    
18.                     d(s) = d(s) + arr(i, 2)
    
19.                 Next
    
20.             End If
    
21.         End If
    
22.     Next f
    
23.     With sh
    
24.         r = .Cells(Rows.Count, 1).End(3).Row
    
25.         arr = .[a1].Resize(r, 5)
    
26.         For i = 2 To UBound(arr)
    
27.             s = arr(i, 1) & "|" & Replace(arr(1, 3), "合计金额", "")
    
28.             If d.exists(s) Then
    
29.                 arr(i, 3) = d(s)
    
30.             End If
    
31.             s = arr(i, 2) & "|" & Replace(arr(1, 4), "合计金额", "")
    
32.             If d.exists(s) Then
    
33.                 arr(i, 4) = d(s)
    
34.             End If
    
35.             arr(i, 5) = arr(i, 4) - arr(i, 3)
    
36.         Next
    
37.         .[a1].Resize(1, 5).Interior.Color = 49407
    
38.         With .[a1].Resize(r, 5)
    
39.             .Value = arr
    
40.             .Borders.LineStyle = 1
    
41.             .HorizontalAlignment = xlCenter  '//列居中
    
42.             .VerticalAlignment = xlCenter
    
43.         End With
    
44.     End With
    
45.     Set d = Nothing
    
46.     Application.ScreenUpdating = True
    
47.     MsgBox "OK！"
    
48. End Sub
    

复制代码

limonet

关键字：Cn.OpenSchema+LEFT JOIN

limonet

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