|
学习日志
批量合并excel工作簿中同名工作表，适用条件： 1、所有要汇总的工作簿在同一个文件夹中，这里以后缀为.xlsx为例； 2、需要合并的工作表名称相同（如： “sheet1”）,且数据字段一样（如：A列表示序号，B列表示姓名，C列表示月工资等,本例中指定数据位于a-c列）； 3、需要合并的数据所在区域起始行列一致（如：有相同的表头）
ALL IN ONE
Sub allinone()
Dim path As String, filename As String
Dim ws As Workbook, w As Workbook
Dim starrow As Long, n As Long, r As Long, titlerow As Integer
path = "C:\Users\Lee\Desktop\新建文件夹\全民一起VBA 提高篇\12"
filename = Dir(path & "\*.xlsx")
Set ws = Workbooks.Add
'每次复制时开始的行数
starrow = 1: n = 0: titlerow = 1
Application.DisplayAlerts = False
Do While filename ""
Set w = Workbooks.Open(path & "\" & filename)
n = n + 1
'以下复制分表数据，第一张含表头，其他表格只复制数据区
With w.Worksheets("sheet1")
'xlCellTypeLastCell 可用11代替
'Cells.SpecialCells(11).Row 包含字符的最后一个单元格所在行号
r = Cells.SpecialCells(xlCellTypeLastCell).Row
If n = 1 Then
.Range("a1", "c" & r).Select
Else
.Range("a" & (titlerow + 1), "c" & r).Select
End If
End With
Selection.Copy
w.Close
With ws.Worksheets("sheet1")
.Range("b" & starrow).Select
.Paste
.Range("a" & starrow, "a" & (starrow + r - titlerow)) = Mid(filename, 1, Len(filename) - 5)
End With
'复制完后，根据B列中最后数据所在行号，重定义下次复制数据开始行号
'.End(xlUp).Row指数据区域最后一行行号
starrow = Range("b" & Rows.Count).End(xlUp).Row + 1
filename = Dir
Loop
With ws.Worksheets("sheet1")
.Range("a1", "a" & titlerow) = ""
.Range("a" & Rows.Count).End(xlUp).value = ""
End With
Application.DisplayAlerts = True
ws.SaveAs path & "\合并2.xlsx"
End Sub
|