合并多个工作簿-2

大家好，之前写过一个程序，是将多个工作簿合并成一个工作簿，不同的工作簿复制到不同的sheet，sheet以工作簿的名称命名，今天这个是将多个工作簿合并到一个sheet，并在对应的第一列标注工作簿名称。

• 之前合并代码电梯：
  合并多个工作簿
  
  
• 文件示例-所有工作表
  

• 分表示例
  

• 合并后示例

• 代码讲解
  

Sub 汇总()

Application.ScreenUpdating = False

Application.DisplayAlerts = False

Dim myrow, lastrow As Long

Dim mySht As Worksheet

Dim fname As String

Set mySht = ThisWorkbook.Sheets('合并')

myrow = 2  '从第二行开始粘贴

'清空历史数据

mySht.Range('A2:E50000') = ''

'生成查找EXCEL的目录

fname = Dir(ThisWorkbook.Path & '\*.xlsx')

'在目录中循环

Do While fname <> ''

 '如果不是当前的汇总工作簿

If fname <> ThisWorkbook.Name Then

'打开工作簿

 Workbooks.Open ThisWorkbook.Path & '\' & fname  

 

'激活第一个sheet

With Workbooks(fname)

.Sheets(1).Activate

      

 '查找该工作簿最后一行的行值        

  lastrow = .Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row  

 

'从第二行第一列到最后一行第四列复制到当前工作簿的第二行第二列    

 .Sheets(1).Range(Cells(2, 1), Cells(lastrow, 4)).Copy mySht.Cells(myrow, 2)  

'将被复制的工作表的名字（即部门名称）写入到对应人员的第一列

mySht.Range(mySht.Cells(myrow, 1), mySht.Cells(myrow + lastrow - 1, 1)) = Split(fname, '.')(0) 

 '行值累加，方便下个工作簿找到从哪一行开始复制

 myrow = myrow + lastrow - 1 

 End With

 '关闭打开的工作簿，不保存 

Workbooks(fname).Close savechanges:=False 

 End If

 

fname = Dir

Loop

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

----------------------------------------