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

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