Merge files and put same column together

[Gary5415]

Dear Everyone,
I have 500 files want to merge,
I want merge file like below red box showing, different file and same column data merge to one sheet,
I try Power Query, but always different data stack at one sheet...
Any ideas would be much appreciated, thanks!

 

[maabadi]

Welcome to Mrexcel Message Board.
Are your first column has same arrangement and Data at each file or should be searched and data vlookup for column XX & YY?

 

[Gary5415]

First column is same arrangement at each files

 

[maabadi]

If your destination workbook has sheet1 & sheet2 empty. Try this:

Sub ImportFiles() Dim wbNew As Workbook, strPath As String, xWS As Worksheet, xMWS As Worksheet, xTWB As Workbook 
Dim xStrAWBName As String, Sh1 As Worksheet, FolderName As String, R As Long, Lr1 As Long 
Dim FolderPath As String, fldr As FileDialog, sItem As String, FileName As String, Lr2 As Long 
Dim LC As Long 
On Error Resume Next  
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)    
With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
      If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)    
End With 
NextCode:    
FolderName = sItem    
Set fldr = Nothing    
FolderPath = FolderName & "\"   
Set xTWB = ThisWorkbook 
Set Sh1 = xTWB.Sheets("Sheet1")
Set Sh2 = xTWB.Sheets("Sheet2")
LC = 1
FileName = Dir(FolderPath & "*.xls*") 
Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 
Application.DisplayAlerts = False 
Do While FileName <> "" 
Workbooks.Open 
FileName:=FolderPath & FileName, ReadOnly:=True 
xStrAWBName = ActiveWorkbook.Name 
For Each xWS In ActiveWorkbook.Sheets 
R = Application.WorksheetFunction.CountA(xWS.Range("A1:Z200")) 
If R > 0 Then
Lr1 = xWS.Range("A" & Rows.Count).End(xlUp).Row 
LC = LC + 1
Lr2 = xTWB.Sh1.Range("A" & Rows.Count).End(xlUp).Row
If LC = 2 Then
xWS.Range(Cells(1, 1), Cells(Lr1, 1)).Copy xTWB.Sh1.Range("A1" ) 
xWS.Range(Cells(1, 1), Cells(Lr1, 1)).Copy xTWB.Sh2.Range("A1" )
End if
xWS.Range(Cells(1, 2), Cells(Lr1, 2)).Copy xTWB.Sh1.Cells(1,  LC)
xWS.Range(Cells(1, 3), Cells(Lr1, 3)).Copy xTWB.Sh2.Cells(1,  LC)
End If 
Next xWS 
Workbooks(xStrAWBName).Close 
FileName = Dir() 
Loop 
xTWB.SaveAs 
FileName:="D:\Consolidation", FileFormat:=xlWorkbookNormal Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
Application.Calculation = xlCalculationAutomatic 
End Sub

 

[Gary5415]

maabadi
Thanks!

 

[maabadi]

You're Welcome & Thanks for feedback.