多sheet合并同时新增列

TT_8279

已于 2023-03-27 15:33:22 修改

阅读量271

点赞数

文章标签： excel

于 2023-03-27 14:03:24 首次发布

本文链接：https://blog.csdn.net/weixin_41475327/article/details/129794186

版权

这段VBA代码用于删除名为合并的工作表，然后创建一个新的合并工作表，并将所有其他非合并工作表的数据粘贴到新表中。数据从找到SPC的行开始，直到最后一列。同时，它还会在第一行添加表名作为标识。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

Sub 合并当前工作簿下的所有工作表()
On Error Resume Next
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("合并").Delete
Set st = Worksheets.Add(before:=Sheets(1))
st.Name = "合并"
For Each shet In Sheets:
If shet.Name <> "合并" Then
i = st.Range("A" & Rows.Count).End(xlUp).Row
r = shet.UsedRange.Find("SPC").Row - 1
c = shet.Cells(4, Columns.Count).End(xlToLeft).Column
shet.Activate
If i > 1 Then i = st.Range("A" & Rows.Count).End(xlUp).Row + 1
If i = 1 Then
shet.Range(Cells(4, 1), Cells(r, c)).Copy
Else
shet.Range(Cells(5, 1), Cells(r, c)).Copy
End If
st.Activate
Cells(i, 1).PasteSpecial Paste:=xlPasteAll
If i = 1 Then c1 = Cells(1, Columns.Count).End(xlToLeft).Column + 1: Cells(i, c1) = "表格名字"
i = Cells(Rows.Count, c1).End(xlUp).Row: ii = Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(i + 1, c1), Cells(ii, c1)) = shet.Name
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "已完成"
End Sub