用VBA再汇总里如何一键提取，求大神帮忙

Jerry6455

这个是7个文件，想在汇总表里，按分类提取

1

2
上面是分三类，省市，街道和托管，按照单位编码能分出各自的分类并提取单位名称，按照编码提取出当年的欠费总额添加到汇总表中。请大神帮忙
我这是编写了7个文件，目前有一百多家，每天汇总太费劲，求大神如何用VBA实现一键操作。

shiruiqiang

2016年为啥要分上半年和下半年？
汇总倒简单，分上、下半年需要多判断

Jerry6455

shiruiqiang 发表于 2024-4-18 14:15
2016年为啥要分上半年和下半年？
汇总倒简单，分上、下半年需要多判断

可以不用分上下半年，都按整年算都可以，之前是分上下半年。

shiruiqiang

减轻一下工作量吧

Jerry6455

shiruiqiang 发表于 2024-4-18 15:45
减轻一下工作量吧

谢谢，你这是咋搞定的，我咋没弄出来

Jerry6455

Jerry6455 发表于 2024-4-18 14:26
可以不用分上下半年，都按整年算都可以，之前是分上下半年。

看到了，能不能把名称也提取出来啊

baofa2

1. Sub test0() '更新一下，仅供测试，不适用于WPS
   
2.   
   
3.   Dim ar, br, Conn As Object, dic As Object, dict As Object
   
4.   Dim s As String, p As String, f As String
   
5.   Dim strConn As String, SQL As String
   
6.   Dim i As Long, j As Long, k As Long
   
7.   
   
8.   Application.ScreenUpdating = False
   
9.   
   
10.   Set dic = CreateObject("Scripting.Dictionary")
    
11.   Set dict = CreateObject("Scripting.Dictionary")
    
12.   Set Conn = CreateObject("ADODB.Connection")
    
13.   
    
14.   With Range(Range("B2").End(xlDown).Offset(, -1), Cells(2, Columns.Count).End(xlToLeft))
    
15.     .Offset(1, 4).ClearContents
    
16.     .Columns(3).Offset(1).ClearContents
    
17.     ar = .Value
    
18.   End With
    
19.   For i = 5 To UBound(ar, 2)
    
20.     s = Replace(ar(1, i), "年", "")
    
21.     If Not dic.Exists(s) Then dic.Add s, i
    
22.   Next
    
23.   For i = 2 To UBound(ar)
    
24.     s = ar(i, 4)
    
25.     If Not dic.Exists(s) Then dic.Add s, i
    
26.   Next
    
27.   
    
28.   s = "Excel 12.0;HDR=YES;Database="
    
29.   If Application.Version < 12 Then
    
30.     s = Replace(s, "12.0", "8.0")
    
31.     strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
    
32.   Else
    
33.     strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
    
34.   End If
    
35.   Conn.Open strConn & ThisWorkbook.FullName
    
36.   
    
37.   p = ThisWorkbook.Path & "\"
    
38.   f = Dir(p & "*.xls*")
    
39.   SQL = "SELECT 单位名称,单位编号,FORMAT(`对应费款_所属期`,'0000-00') AS 期,`单位应_缴金额`*1 AS 额 FROM [" & s & p & "[.f]].[单位欠费信息查询$B5:L] WHERE LEN(单位编号)"
    
40.   Do
    
41.     If p & f <> ThisWorkbook.FullName Then
    
42.       dict.Add Replace(SQL, "[.f]", f), vbNullString
    
43.       If dict.Count = 40 Then
    
44.         br = Conn.Execute(Join(dict.Keys, " UNION ALL ")).GetRows()
    
45.         ProcessData ar, br, dic
    
46.         dict.RemoveAll
    
47.       End If
    
48.     End If
    
49.     f = Dir
    
50.   Loop While Len(f)
    
51.   
    
52.   If dict.Count Then
    
53.     br = Conn.Execute(Join(dict.Keys, " UNION ALL ")).GetRows()
    
54.     ProcessData ar, br, dic
    
55.   End If
    
56.   
    
57.   Dim total(1)
    
58.   ReDim sum_(5 To UBound(ar, 2)) As Double
    
59.   For k = 0 To UBound(total)
    
60.     total(k) = sum_
    
61.   Next
    
62.   For i = 2 To UBound(ar)
    
63.     For j = LBound(sum_) To UBound(sum_)
    
64.       For k = 0 To UBound(total)
    
65.         total(k)(j) = total(k)(j) + Val(ar(i, j))
    
66.       Next
    
67.     Next
    
68.     If InStr(ar(i, 2), "汇总") Then
    
69.       For j = LBound(sum_) To UBound(sum_)
    
70.         If total(0)(j) Then ar(i, j) = total(0)(j)
    
71.         total(0)(j) = 0
    
72.       Next
    
73.     End If
    
74.     If InStr(ar(i, 2), "总计") Then
    
75.       For j = LBound(sum_) To UBound(sum_)
    
76.         If total(1)(j) Then ar(i, j) = total(1)(j)
    
77.       Next
    
78.     End If
    
79.   Next
    
80.   
    
81.   With Range("A2")
    
82.     With .Resize(UBound(ar), UBound(ar, 2))
    
83.       .Columns(4).NumberFormatLocal = "@"
    
84.       .Value = ar
    
85.     End With
    
86.   End With
    
87.   
    
88.   Conn.Close
    
89.   Set Conn = Nothing
    
90.   Set dic = Nothing
    
91.   Set dict = Nothing
    
92.   
    
93.   Application.ScreenUpdating = True
    
94.   Beep
    
95. End Sub
    
96. 
    
97. Function ProcessData(ar, br, dic As Object)
    
98.   Dim cr, j As Long, s As String, posRow As Long, posCol As Long
    
99.   For j = 0 To UBound(br, 2)
    
100.     If Not IsNull(br(3, j)) Then
     
101.       posCol = 0
     
102.       s = Trim(br(1, j))
     
103.       If dic.Exists(s) Then
     
104.         posRow = dic(s)
     
105.         If ar(posRow, 3) = "" Then ar(posRow, 3) = br(0, j)
     
106.         cr = Split(br(2, j), "-")
     
107.         If dic.Exists(cr(0)) Then posCol = dic(cr(0)) Else posCol = dic(cr(0) & Array("上", "下")(1 + (Val(cr(1)) < 7)))
     
108.         If posCol Then
     
109.           ar(posRow, posCol) = ar(posRow, posCol) + br(3, j)
     
110.           ar(posRow, UBound(ar, 2)) = ar(posRow, UBound(ar, 2)) + br(3, j)
     
111.         End If
     
112.       End If
     
113.     End If
     
114.   Next
     
115. End Function

复制代码

shiruiqiang

Jerry6455

我想知道，你是进入到VBA界面直接敲代码吗，还是通过宏一步一步操作的。

Jerry6455

baofa2 发表于 2024-4-18 18:56

谢谢，到时候我用Office测试一下。