Sub 合并工作表()
Dim Sht As Worksheet, rng As Range, k&, n&, c&, a&, b&
Dim result As Integer
Application.ScreenUpdating = False
'取消屏幕更新
n = Val(InputBox("请输入标题的行数", "默认为1", 1))
If n < 0 Then MsgBox "标题行数不能为负数。", 64, "提示": Exit Sub
'取得用户输入的标题行数,如果为负数,退出程序
Cells.ClearContents
'清空当前表数据
a = 1 '从a1开始填充
For Each Sht In Worksheets
'遍历工作表
If Sht.Name <> ActiveSheet.Name Then
'如果工作表名称不等于当前表名则进行汇总动作……
Set rng = Sht.UsedRange
'定义rng为表格已用区域
k = k + 1 '标记是不是第一张表
'累计K值
If k = 1 Then
'如果是首个表格,则K为1,则把标题行一起复制到汇总表
rng.Copy
[b1].PasteSpecial Paste:=xlPasteValues '仅粘贴数值 第一列留给工作表名
c = Sht.UsedRange.Rows.Count '计算收割表的行数
Else
'否则,扣除标题行后再复制黏贴到总表,只黏贴数值
rng.Offset(n).Copy
Cells(ActiveSheet.UsedRange.Rows.Count + 1, 2).PasteSpecial Paste:=xlPasteValues
c = Sht.UsedRange.Rows.Count - n '计算当前表的行数
End If
c = c + b '加上之前表的行数
Range("A" & a & ":A" & c).Value = Sht.Name
a = c + 1 '从以使用的表行的下一行开始粘贴
b = c '存储上一次表的粘贴行数
End If
Next
Range("A1").Value = "工作表名"
Application.ScreenUpdating = True '恢复屏幕刷新
End Sub