多个工作表内容汇总

ppl123

请老师帮实现合并当前工作簿下的所有工作表内容到汇总表 Sheet.rar (26.12 KB, 下载次数: 25)

2023-12-6 08:39 上传

点击文件名下载附件

Tina.棠

Sub 合并表格数据()
    Dim 合并表 As Worksheet
    Set 合并表 = ThisWorkbook.Sheets("合并")

    Dim 源表格 As Worksheet
    Dim 目标行 As Long

    ' 遍历每个源表格
    For Each 源表格 In ThisWorkbook.Sheets
        ' 排除合并表格本身
        If 源表格.Name <> "合并" Then
            ' 寻找目标行，确保不覆盖已有数据
            目标行 = 合并表.Cells(合并表.Rows.Count, "A").End(xlUp).Row + 1

            ' 复制数据
            源表格.Range("D6:AI" & 源表格.Cells(源表格.Rows.Count, "D").End(xlUp).Row).Copy _
            合并表.Range("A" & 目标行)
        End If
    Next 源表格

    MsgBox "数据合并完成！", vbInformation
End Sub

按钮绑定这个宏。这个是把所有sheet全贴过去了，如果只要指定的五张表的话，
原代码： If 源表格.Name <> "合并" Then
修改为： If 源表格.Name = "表一" or 源表格.Name = "表二" or 源表格.Name = "表三"or 源表格.Name = "表四" or 源表格.Name = "表五" Then

3190496160

Sub 合并()
Dim sh As Worksheet
With Sheets("合并")
    .UsedRange.Clear
    For Each sh In Sheets
        If sh.Name <> "合并" Then
            r = sh.Cells(sh.Rows.Count, 4).End(xlUp).Row
            rs = .Cells(.Rows.Count, 2).End(xlUp).Row + 1
            sh.Range("d6:ai" & r).Copy .Cells(rs, 2)
        End If
    Next sh
End With
MsgBox "ok!"
End Sub

3190496160

Sheet.rar (30.38 KB, 下载次数: 18)

2023-12-6 09:43 上传

点击文件名下载附件

ppl123

3190496160 发表于 2023-12-6 09:43

老师，如果某一个表中出现内容不连接，给怎样并在一起呢

3190496160

ppl123 发表于 2023-12-6 09:51
老师，如果某一个表中出现内容不连接，给怎样并在一起呢

那代码就是另外一个思路了，就得循环行了

3190496160

Sub 合并()
Dim sh As Worksheet
Dim ar As Variant
Dim br()
ReDim br(1 To 100000, 1 To 32)
With Sheets("合并")
    .UsedRange.Clear
    For Each sh In Sheets
        If sh.Name <> "合并" Then
            r = sh.Cells(sh.Rows.Count, 4).End(xlUp).Row
            ar = sh.Range("d6:ai" & r)
            For i = 1 To UBound(ar)
                If ar(i, 1) <> "" Then
                    n = n + 1
                    For j = 1 To UBound(ar, 2)
                        br(n, j) = ar(i, j)
                    Next j
                End If
            Next i
        End If
    Next sh
    .[b2].Resize(n, UBound(br, 2)) = br
End With
MsgBox "ok!"
End Sub

3190496160

Sheet.rar (28.31 KB, 下载次数: 23)

2023-12-6 10:27 上传

点击文件名下载附件

yynrzwh

Sheet.rar (32.51 KB, 下载次数: 13)

2023-12-6 10:51 上传

点击文件名下载附件

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2023.12.6
   
2.     Application.ScreenUpdating = False
   
3.     Set sh = ThisWorkbook.Sheets("合并")
   
4.     sh.UsedRange.Offset(1).Clear
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             m = m + 1
   
8.             With sht
   
9.                 r1 = .Cells(Rows.Count, 4).End(3).Row
   
10.                 Set Rng = .Range("d6:ai" & r1)
    
11.                 r = IIf(m = 1, 2, sh.Cells(Rows.Count, 2).End(3).Row + 1)
    
12.                 Rng.Copy sh.Cells(r, 2)
    
13.             End With
    
14.         End If
    
15.     Next
    
16.     Application.ScreenUpdating = True
    
17.     MsgBox "OK！"
    
18. End Sub
    

复制代码