Consolidate Data Through VBA from different workbooks

[Andresuru]

Hi Excel Community,

Please note I am trying to consolidate data through VBA, I am still learning regarding VBA so appreciate your help. ( Note: The solution cannot be using power query)
Basically I need to open like 12 excel files and see if the sheets("Template") (Same name sheet is in all workbooks) , if has data from row 2 to end then copy and paste into the master files (Master)
and then do the same for the rest of the files but probably from the second file data will paste in the next row in blank.

'Option Private Module


Sub Extraction()

With Application


.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.EnableEvents = False

Dim Master As Workbook

Set Master = ThisWorkbook


    On Error Resume Next

'________________________________________________________________________________________________________X1

    Workbooks.Open Filename:="L:\2022\XXX\X1\Template.xlsm"
    
    Sheets("Rule").Select
    
    'If Range("E2") <> Empty Then ' I was trying to do it but I cannot find a solution to avoid leaving data
    
    Rows("2:25000").Select
    Selection.Copy
    
            Master.Activate
            Sheets("Changes Required").Select
            Selection.Range("A2").PasteSpecial
            
                Workbooks("Template").Close savechanges:=False
    
    'End If
    
'________________________________________________________________________________________________________X2

  Workbooks.Open Filename:="L:\2022\XXX\X2\Template.xlsm"
    
    Sheets("Rule").Select
    
    'If Range("E2") <> Empty Then ' I was trying to do it but I cannot find a solution to avoid leaving data
    
    Rows("2:25000").Select
    Selection.Copy
    
            Master.Activate
            Sheets("Changes Required").Select
            
            '___________________________________________________________Copy data in the next blank row
            
            Range("F" & Rows.Count).End(xlUp).Offset(1, -5).PasteSpecial 
            
            Workbooks("Template").Close savechanges:=False
    
    'End If

'________________________________________________________________________________________________________X3



  Workbooks.Open Filename:="L:\2022\XXX\X3\Template.xlsm"
    
      
    Sheets("Rule").Select
    
    'If Range("E2") <> Empty Then ' I was trying to do it but I cannot find a solution to avoid leaving data
    
    Rows("2:25000").Select
    Selection.Copy
    
            Master.Activate
            Sheets("Changes Required").Select
            
            '___________________________________________________________Copy data in the next blank row
            
            Range("F" & Rows.Count).End(xlUp).Offset(1, -5).PasteSpecial
            
            Workbooks("Template").Close savechanges:=False
    
    'End If

'_______________________________________________________________________________________________________

.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.EnableEvents = True

End With
End Sub

I guess maybe this code can explain you better the idea.

Regards
Andres

 

[DanteAmor]

Try this:

Sub Extraction_2()
  Dim sPath As String, sFile As String, sName As String
  Dim i As Long, lr1 As Long, lr2 As Long
  Dim wb2 As Workbook
  Dim sh As Worksheet
  
  With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
    .AskToUpdateLinks = False
    .EnableEvents = False
  End With
  
  'Your Data:
  Set sh = ThisWorkbook.Sheets("Changes Required")
  sFile = "Template.xlsm"
  sName = "Rule"
  
  For i = 1 To 12
    sPath = "L:\2022\XXX\X" & i & "\"
    If Dir(sPath, vbDirectory) <> "" Then
      If Dir(sPath & sFile) <> "" Then
        Set wb2 = Workbooks.Open(sPath & sFile)
        If Evaluate("ISREF('" & sName & "'!A1)") Then
          With wb2.Sheets(sName)
            lr2 = .UsedRange.Rows(.UsedRange.Rows.Count).Row
            lr1 = sh.UsedRange.Rows(sh.UsedRange.Rows.Count).Row + 1
            .Rows("2:" & lr2).Copy
            sh.Range("A" & lr1).PasteSpecial xlPasteValues
          End With
        End If
        wb2.Close False
      End If
    End If
  Next
  
  With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
    .AskToUpdateLinks = True
    .EnableEvents = True
  End With
End Sub