请帮忙合并各工作表，合并后增加一列所属期，多谢！

TSGRH

请帮忙 将所有工作表合并在一个表后，只保留一个标题，在最左增加一列为所属期，取每个表F1单元格为所属期。多谢！

wang-way

ykcbf1100

多表合并。。。

ykcbf1100

多表合并。。。

1. Sub ykcbf()            '//2024.7.24  多表合并
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set sh = ThisWorkbook.Sheets("想要的表")
   
5.     Dim t: t = Timer
   
6.     Dim brr(1 To 10000, 1 To 100)
   
7.     For Each sht In Sheets
   
8.         If sht.Name <> sh.Name Then
   
9.             arr = sht.UsedRange
   
10.             For i = 3 To UBound(arr)
    
11.                 If Len(arr(i, 1)) Then
    
12.                     m = m + 1
    
13.                     brr(m, 1) = sht.Name
    
14.                     For j = 1 To UBound(arr, 2)
    
15.                         brr(m, j + 1) = arr(i, j)
    
16.                     Next j
    
17.                 End If
    
18.             Next i
    
19.         End If
    
20.     Next
    
21.     With sh
    
22.         .UsedRange.Offset(1).Clear
    
23.         .Columns("a:k").NumberFormatLocal = "@"
    
24.         With .[a2].Resize(m, 19)
    
25.             .Value = brr
    
26.             .Borders.LineStyle = 1
    
27.             .HorizontalAlignment = xlCenter
    
28.             .VerticalAlignment = xlCenter
    
29.             .EntireColumn.AutoFit   '//自动列宽
    
30.             With .Font
    
31.                 .Name = "微软雅黑"
    
32.                 .Size = 11
    
33.             End With
    
34.         End With
    
35.     End With
    
36.     MsgBox "运行完毕，共用时： " & Format(Timer - t, "0.000秒"), , "提示"
    
37. End Sub
    

复制代码

黎花埠

Sub 汇总()
    Dim i&, j&, X, Arr
    iMsg = MsgBox("是否清除原有数据？", 4 + 32)
    If iMsg = 6 Then Worksheets(1).[A1].CurrentRegion.Offset(1, 0).ClearContents
    For i = 2 To Sheets.Count
        With Worksheets(i)
            X = .[F1].Value
            Arr = .[A1].CurrentRegion.Offset(2, 0)
        End With
        With Worksheets(1)
            With .Cells(Rows.Count, 2).End(xlUp)
                .Offset(1, 0).Resize(UBound(Arr), UBound(Arr, 2)) = Arr
                .Offset(1, -1).Resize(UBound(Arr) - 2, 1) = X
            End With
        End With
        Erase Arr
    Next i
End Sub

TSGRH

多谢老师，真快，我测试下。

awen7878

如果仅仅是附件的样子可以用这个试试，如果有差异的话还要完善

TSGRH

多谢以上各位的帮忙。3 楼的老师，能否帮我在你的附件中更改一下。从各表第4行开始合并。因为导出的原始中还有第一行空的，我上传时删除了。 多谢！

TSGRH

,不用了，我改了，多谢老师。

ykcbf1100

TSGRH 发表于 2024-7-25 08:56
多谢以上各位的帮忙。3 楼的老师，能否帮我在你的附件中更改一下。从各表第4行开始合并。因为导出的原始中 ...

改了，自己测试一下吧。