将拆分得到的各表重新复制到表1(数据)
Sub t()
Dim i, j As Integer
Dim sht As Worksheet
'清空数据表中的数据'
Sheet1.Range("a1:f65536").ClearContents
'复制表2的表头到表一'
Sheet2.Range("a1:f1").Copy Sheet1.Range("a1")
'复制数据'
For Each sht In Sheets
If sht.Name <> "数据" Then
'判断表2之后的表共有几行'
i = sht.Range("a65536").End(xlUp).Row
'判断粘贴到表1后内容的行数'
j = Sheet1.Range("a65536").End(xlUp).Row
sht.Range("a2:f" & i).Copy Sheet1.Range("a" & j + 1)
End If
Next
End Sub
进阶 -- 弹出提示框询问用户有表头有几行
Sub t2()
Dim i, j, k As Integer
Dim sht As Worksheet
k = InputBox("请问表头一共有多少行")
'清空数据表'
Sheet1.Range("a1:f65536").ClearContents
'复制表头'
Sheet2.Range("a1:f" & k).Copy Sheet1.Range("a1")
'复制内容'
For Each sht In Sheets
If sht.Name <> 数据 Then
'判断需复制的表一共有多少行'
i = sht.Range("a65536").End(xlUp).Row
'表1中的行数'
j = Sheet1.Range("a65536").End(xlUp).Row
sht.Range("a" & k + 1 & ":f" & i).Copy Sheet1.Range("a" & k + 1 & ":f" & j + 1)
End If
Next
MsgBox "处理完毕"
End Sub
网友评论