用VBA汇总多张工作表

干勇平

求助各位路过高手，如附件所示例，用VBA汇总多张工作表


具体需求：将后面各分表的C-Q列内容复制到本表，分表数量不固定，各分表的列一样，行数各异。
1.根据本表B1单格，当B1的值为某月份时，复制各分表的C列是此月份的内容，不符的月份不复制
2.当B1的值为全部时，复制各分表C列所有的月份内容.
3.目前汇总表为月份是3的示例。
小红花酬谢。

ykcbf1100

附件供参考。。。。

ykcbf1100

1. Sub ykcbf()   '//2025.3.24
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总")
   
4.     xm = sh.[b1].Value
   
5.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             With sht
   
9.                 r = .UsedRange.Find("*", , -4163, , 1, 2).Row
   
10.                 c = .UsedRange.Find("*", , -4163, , 2, 2).Column
    
11.                 arr = .[a1].Resize(r, c)
    
12.                 For i = 4 To UBound(arr)
    
13.                     If Format(arr(i, 3), "m月") = xm Then
    
14.                         m = m + 1
    
15.                         brr(m, 1) = .Name
    
16.                         For j = 2 To UBound(arr, 2)
    
17.                             brr(m, j) = arr(i, j)
    
18.                         Next
    
19.                     End If
    
20.                 Next
    
21.             End With
    
22.         End If
    
23.     Next
    
24.     With sh
    
25.         .[a4:q10000] = Empty
    
26.         .[a4].Resize(m, 17) = brr
    
27.         .[a4].Resize(m, 17).Borders.LineStyle = 1
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    

复制代码

taller

taller

1. 
   
2. Sub Demo()
   
3.     Dim oSht As Worksheet: Set oSht = Sheets("汇总")
   
4.     Dim lastRow As Long: lastRow = oSht.Cells(oSht.Rows.Count, "A").End(xlUp).Row
   
5.     Dim sMth As String: sMth = Trim(oSht.[b1])
   
6.     Dim bAll As Boolean: bAll = (sMth = "全部")
   
7.     If lastRow > 3 Then oSht.Range("4:" & lastRow).Clear
   
8.     Dim vSht, arr(1 To 10000, 16), iR, i, j, brr
   
9.     For Each vSht In Sheets
   
10.         If vSht.Name <> oSht.Name Then
    
11.             brr = vSht.Range("B3").CurrentRegion.Value
    
12.             For i = 3 To UBound(brr)
    
13.                 If bAll Or Month(brr(i, 2)) = Val(sMth) Then
    
14.                     iR = iR + 1
    
15.                     arr(iR, 0) = vSht.Name
    
16.                     arr(iR, 1) = iR
    
17.                     For j = 2 To 16
    
18.                         arr(iR, j) = brr(i, j)
    
19.                     Next
    
20.                 End If
    
21.             Next
    
22.         End If
    
23.     Next
    
24.     With oSht.Range("A4").Resize(iR, 17)
    
25.         .Value = arr
    
26.         .Columns(3).NumberFormat = "yyyy""年""m""月"";@"
    
27.         .Borders.LineStyle = xlContinuous
    
28.     End With
    
29. End Sub
    
30. 
    

复制代码

干勇平

ykcbf1100 发表于 2025-3-24 10:03
附件供参考。。。。

非常感谢。当当B1的值为全部时，复制各分表C列所有的月份内容，如何实现
另外，如果再搞个清除汇总表命令框，该如何

loirol

纯苦力

ykcbf1100

干勇平 发表于 2025-3-24 10:16
非常感谢。当当B1的值为全部时，复制各分表C列所有的月份内容，如何实现
另外，如果再搞个清除汇总表命 ...

改好了。。。

ykcbf1100

只改二行代码就行

1. Sub ykcbf()   '//2025.3.24
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("汇总")
   
4.     xm = sh.[b1].Value
   
5.     ReDim brr(1 To 10 ^ 5, 1 To 100)
   
6.     For Each sht In Sheets
   
7.         If sht.Name <> sh.Name Then
   
8.             With sht
   
9.                 r = .UsedRange.Find("*", , -4163, , 1, 2).Row
   
10.                 c = .UsedRange.Find("*", , -4163, , 2, 2).Column
    
11.                 arr = .[a1].Resize(r, c)
    
12.                 For i = 4 To UBound(arr)
    
13.                     If xm <> "全部" And Format(arr(i, 3), "m月") <> xm Then GoTo 100
    
14.                     m = m + 1
    
15.                     brr(m, 1) = .Name
    
16.                     For j = 2 To UBound(arr, 2)
    
17.                         brr(m, j) = arr(i, j)
    
18.                     Next
    
19. 100:
    
20.                 Next
    
21.             End With
    
22.         End If
    
23.     Next
    
24.     With sh
    
25.         .[a4:q10000] = Empty
    
26.         .[a4].Resize(m, 17) = brr
    
27.         .[a4].Resize(m, 17).Borders.LineStyle = 1
    
28.     End With
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub

复制代码

干勇平

ykcbf1100 发表于 2025-3-24 10:25
改好了。。。

不好意思，可能是误会了
当B1是值是全部时，需要把各分表所月的内容全部复制到汇总表。
那个清空命令，是用来清空汇总表所有复制过来的分表内容，不是清空B1值。