合并识别工作表和工作簿源 VBA 的 excel 工作表和工作簿

Question

我有多个具有相同信息的工作簿和工作表，我一直在尝试合并所有这些文件以识别信息源（工作表 - 工作簿）。

我使用过这段代码，但它只是合并单元格，我无法识别信息源（工作表 - 工作簿）

Sub merge()
Application.DisplayAlerts = False
For Each hoja In ActiveWorkbook.Sheets
If hoja.Name = "todas" Then hoja.Delete
Next
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "todas"
For x = 2 To Sheets.Count
Sheets(x).Select
Range("a1:o" & Range("a650000").End(xlUp).Row).Copy
Sheets("todas").Range("a650000").End(xlUp).Offset(1, 0).PasteSpecial 
Paste:=xlValues
Next
Sheets("todas").Select
End Sub     

这是我必须合并的库之一：

Answer 1

我没有你的工作簿，所以我无法自己测试它，但结构已经存在，因此如果遇到错误，你可以轻松调试它：

Sub merge()
    Dim rng As Range
    Dim cell As Range
    Application.DisplayAlerts = False
    For Each hoja In ActiveWorkbook.Sheets
    If hoja.Name = "todas" Then hoja.Delete
    Next
    Sheets.Add before:=Sheets(1)
    ActiveSheet.Name = "todas"

    For x = 2 To Sheets.Count
        Set rng = Sheets(x).UsedRange
        rng.Copy

        'Cell in column A after the last row
        Set cell = Sheets("todas").Range("a650000").End(xlUp).Offset(1, 0)
        cell.PasteSpecial Paste:=xlValues

        'Define the range that just got pasted (only column A)
        Set rng = cell.Resize(rng.Rows.Count, 1)

        'Offset it to the column next to the last column
        Set rng = rng.Offset(0, rng.Columns.Count)

        rng.Value = Sheets(x).Name 'paste the name ofthe sheet in each row
        Set rng = rng.Offset(0, 1)
        rng.Value = Sheets(x).Parent.Name 'paste the name of the workbook in each row

    Next
    Sheets("todas").Select
    Application.DisplayAlerts = True
End Sub