如何将多个工作簿合并为一个新工作簿，并把原工作簿名称带入新工作表并单独列示一列

jane2942

老师您好，如果要把同一个文件夹中的工作簿合并在一个新工作表中，并且带入源工作簿的文件名，在新工作表中单独显示在一列，现在合并的问题可以做到，但是，工作簿的文件名称没有办法单独列示在新工作表中，我使用的代码是Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
If MyName <> AWbName Then
Set wb = Workbooks.Open(MyPath & "\" & MyName)
Num = Num + 1
With Workbooks(1).ActiveSheet
.Cells(.Range("A65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
For G = 1 To Sheets.Count
wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 1)
Next
WbN = WbN & Chr(13) & wb.Name
wb.Close False
End With
End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

请问老师，如何修改一下，可以做到把工作簿名称带入新工作表中，并且单独列示在一列中，原来的合并效果很好，基本不需要大的改动，只需要把工作簿名称带入，恳请老师百忙中帮助我一下，不胜感激！

jane2942

补充说明，现在合并以后原工作簿名称在数据的上面一行显示，我现在希望把原工作簿名称显示在第一列，而不是显示在数据的上面，拜托大神帮帮忙，感激

3190496160

Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim wb As Workbook, WbN As String
Dim G As Long
Dim Num As Long
Dim BOX As String
Application.ScreenUpdating = False
MyPath = ActiveWorkbook.Path
MyName = Dir(MyPath & "\" & "*.xls")
AWbName = ActiveWorkbook.Name
Num = 0
Do While MyName <> ""
    If MyName <> AWbName Then
       Set wb = Workbooks.Open(MyPath & "\" & MyName)
       Num = Num + 1
       With Workbooks(1).ActiveSheet
          mc = Left(MyName, Len(MyName) - 4)
          r = .Cells(Rows.Count, 1).End(xlUp).Row + 1
          rs = .Cells(Rows.Count, 2).End(xlUp).Row
          For G = 1 To Sheets.Count
            wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 2)
            .Range("a" & r & ":a" & rs) = mc
          Next
          WbN = WbN & Chr(13) & wb.Name
          wb.Close False
       End With
    End If
MyName = Dir
Loop
Range("A1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下：" & Chr(13) & WbN, vbInformation, "提示"
End Sub

jane2942

老师您好，我用您的代码试了一下，现在源工作簿名称是可以带入到新工作表中，但是为什么只有标题过来了，源文件中的数据没有过来，请问这是怎么回事？谢谢老师热心指点

jane2942

3190496160 发表于 2022-3-16 14:26
Sub 合并当前目录下所有工作簿的全部工作表()
Dim MyPath, MyName, AWbName
Dim wb As Workbook, WbN As ...

老师您好，我用您的代码试了一下，现在源工作簿名称是可以带入到新工作表中，但是为什么只有源文件中的表头标题过来了，源文件中的数据没有过来，请问这是怎么回事？谢谢老师热心指点

3190496160

wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 2)
修改为：
wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 2)

jane2942

3190496160 发表于 2022-3-17 09:41
wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 2)
修改为：
wb.Sheets(G). ...

老师，您好，已经可以了，就是不知道合并数据为什么会跑到其他路径下打开状态的工作簿里面，而不是源文件路径下运行宏文件的工作簿里面，其他问题暂时没发现

jane2942

3190496160 发表于 2022-3-17 09:41
wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 2)
修改为：
wb.Sheets(G). ...

老师，您好，试了您说的方法，现在文件名可以带入到合并工作表中，但是，文件名和对应的数据是不匹配的，就是说，张三的数据但是前面的文件名称显示是李四，

jane2942

3190496160 发表于 2022-3-17 09:41
wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 2)
修改为：
wb.Sheets(G). ...

老师您好，还有一个问题，就是合并以后的数据和文件名称不匹配，是错位的，不知道该怎么修改啊，感谢老师的热心指点，

jane2942

3190496160 发表于 2022-3-17 09:41
wb.Sheets(G).UsedRange.Copy .Cells(.Range("A65536").End(xlUp).Row + 1, 2)
修改为：
wb.Sheets(G). ...

老师，还有一个问题，就是合并后的文件名和数据是不匹配的，是错位的，见图片中相同颜色的数据是配套的，应该怎么修改，请老师指教，拜谢