求助老师excel自动汇总

孤独的漫游

附件：

第一个工资表为需要汇总的

后面是我自己随时更新增加的各工作表，后面的个工作表的内容也会不定时的自己更新

求助老师设置自动汇总到第一个工作表。

dragonthree

遍历工作表就可以了吧

孤独的漫游

dragonthree 发表于 2024-1-24 10:33
遍历工作表就可以了吧

不懂阿。。。。。。。。。。

3190496160

Sub 汇总()
Dim ar As Variant
Dim br()
Dim sh As Worksheet
ReDim br(1 To 100000, 1 To 9)
For Each sh In Sheets
    If sh.Index > 1 Then
         r = sh.Cells(Rows.Count, 4).End(xlUp).Row
         ar = sh.Range("b6:j" & r)
         For i = 2 To UBound(ar)
            If Trim(ar(i, 4)) <> "" Then
                n = n + 1
                br(n, 1) = n
                For j = 2 To UBound(ar, 2)
                    br(n, j) = ar(i, j)
                Next j
            End If
        Next i
    End If
Next sh
If n = "" Then MsgBox "没有需要汇总的数据！": End
With Sheets("文件总目录(汇总)")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    If rs >= 7 Then .Range("b7:j" & rs).Borders.LineStyle = 0: .Range("b7:j" & rs) = Empty
    .[b7].Resize(n, UBound(br, 2)) = br
    .[b7].Resize(n, UBound(br, 2)).Borders.LineStyle = 1
End With
MsgBox "ok!"
End Sub

3190496160

文件目录.rar (51.45 KB, 下载次数: 28)

2024-1-24 11:10 上传

点击文件名下载附件

孤独的漫游

3190496160 发表于 2024-1-24 11:10

谢谢老师。。。。

fshhhf

凑热闹，。。。。。。。

ykcbf1100

参与一下。。。

1. Sub 多表合并()  '//2024.1.24
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = Sheets("文件总目录(汇总)")
   
4.     sh.UsedRange.Offset(6).ClearContents
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             With sht
   
8.                 arr = .UsedRange
   
9.                 If UBound(arr) > 1 Then
   
10.                     r = sh.Cells(sh.Rows.Count, 2).End(3).Offset(1).Row
    
11.                     r1 = .Cells(.Rows.Count, 2).End(3).Row
    
12.                     .Range("b7:j" & r1).Copy sh.Cells(r, 2)
    
13.                 End If
    
14.             End With
    
15.         End If
    
16.     Next
    
17.     With sh
    
18.         r = .Cells(.Rows.Count, 2).End(3).Row
    
19.         .[b7] = 1
    
20.         .[b7].AutoFill Destination:=.Range("b7:b" & r), Type:=xlFillSeries
    
21.     End With
    
22.     Application.ScreenUpdating = True
    
23.     MsgBox "OK！"
    
24. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

孤独的漫游

ykcbf1100 发表于 2024-1-24 16:08
附件供参考。。。

谢谢。。。。。。。。