Fusionner des feuilles Excel et des classeurs identifiant la feuille et la source Wooork VBA

Question

J'ai plusieurs classeurs et feuilles de calcul avec les mêmes informations, j'ai essayé de fusionner tous ces fichiers identifiant la source d'information (Worksheet - classeur).

je l'ai utilisé ce code, mais il fusionner seulement les cellules et je ne pouvais pas identifier la source d'information (feuille de calcul - Cahier d'exercices)

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  

Ceci est l'une des bibliothèques je dois fusionner:

Answer 1

Je n'ai pas votre classeur, donc je ne pouvais pas tester moi-même, mais la structure est là pour que vous pouvez déboguer facilement si vous exécutiez dans une erreur:

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