find columns with same headers in multiple worksheet and coping column in new sheet

[gogi100]

i have workbook, where i need a macro that he finds columns with same headers, and he copies data new sheet. colomns in different order in sheets. this is my code, he works with the sheets that that have same order of columns

Sub Merge_Sheets()

  Dim startRow, startCol, lastRow, lastCol As Long
Dim headers As Range
Dim ws As Worksheet
Dim pas As Worksheet

'Set Master sheet for consolidation
Set wb = ActiveWorkbook
Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "AllSheets"
Set mtr = Worksheets("AllSheets")
Sheets("Sheet1").Activate
'Get Headers
Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)

'Copy Headers into master
headers.Copy mtr.Range("A1")
startRow = headers.Row + 1
startCol = headers.Column

Debug.Print startRow, startCol
'loop through all sheets
For Each ws In wb.Worksheets
     'except the master sheet from looping
     If ws.Name <> "AllSheets" Then
        ws.Activate
        lastRow = Cells(Rows.Count, startCol).End(xlUp).Row
        lastCol = Cells(startRow, Columns.Count).End(xlToLeft).Column
        'get data from each worksheet and copy it into AllSheets sheet
        Range(Cells(startRow, startCol), Cells(lastRow, lastCol)).Copy _
        mtr.Range("A" & mtr.Cells(Rows.Count, 1).End(xlUp).Row + 1)
           End If
Next ws

Sheets("AllSheets").Activate
End Sub

 

[gogi100]

my macro is in private workbook

 

[gogi100]

i found solution with next code

Sub MasterMine()

Dim Master As Worksheet
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet
Dim Found As Range
Dim i As Long
Dim Arr() As Variant
Dim pas As Worksheet
Dim headers As Range
Dim SheetExists As Boolean
  'Set Master sheet for consolidation
  Set wb = ActiveWorkbook
  SheetExists = False
  Set pas = ActiveSheet
  For Each ws In ActiveWorkbook.Sheets
  If ws.Name = "AllSheets" Then
  SheetExists = True
  End If
  Next ws
 
 
  If SheetExists = False Then
 
    Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "AllSheets"
    Set Master = ActiveWorkbook.Sheets("AllSheets")
    pas.Activate
    'Get Headers
    Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)
    'Copy Headers into master
    headers.Copy Master.Range("A1")
    LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
  ElseIf SheetExists = True Then
    
     Set Master = ActiveWorkbook.Sheets("AllSheets")
     pas.Activate
     LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
     If IsEmpty(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value) Then
        MsgBox "Postoji Sheet AllSheets, ali nema imena kolona. Unesite nazive kolona!"
        End
     End If
     If LC1 = 1 Then
     Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
     Else
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
    End If
    
  End If
 
For Each ws In ActiveWorkbook.Sheets
    If ws.Name <> "AllSheets" Then
    
    For i = LBound(Arr) To UBound(Arr)
        LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
         Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i), LookIn:=xlValues)
            If Not Found Is Nothing Then
                LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i).PasteSpecial xlPasteValues
            End If
    Next i
    End If
    
Next ws
End Sub

but i have one more problem. when i type range A1 i receive error run-time error 13, typemismatch. and when i click on debug i go to line

Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))

What i do?

 

[gogi100]

i modified my code and this code works with range A1

Sub MasterMine()

Dim Master As Worksheet
Dim LR1 As Long, LR2 As Long, LC1 As Long, LC2 As Long
Dim ws As Worksheet
Dim Found As Range
Dim i As Long
Dim Arr As Variant
Dim r2 As Variant
Dim pas As Worksheet
Dim headers As Range
Dim SheetExists As Boolean
  'Set Master sheet for consolidation
  Set wb = ActiveWorkbook
  SheetExists = False
  Set pas = ActiveSheet
  For Each ws In ActiveWorkbook.Sheets
  If ws.Name = "AllSheets" Then
  SheetExists = True
  End If
  Next ws
 
 
  If SheetExists = False Then
 
    Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count)).Name = "AllSheets"
    Set Master = ActiveWorkbook.Sheets("AllSheets")
    pas.Activate
    'Get Headers
    Set headers = Application.InputBox("Izaberi opseg Header-a", Type:=8)
    'Copy Headers into master
    headers.Copy Master.Range("A1")
    LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
    If LC1 = 1 Then
    
        r2 = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
          ReDim Arr(0 To Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Count) ' redim array size to 1 (only 1 cell in range)
        Arr(0) = r2
         'Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
    Else
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
    End If
    
    'Arr = Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value
  ElseIf SheetExists = True Then
    
     Set Master = ActiveWorkbook.Sheets("AllSheets")
     pas.Activate
     LC1 = Master.Cells(1, Master.Columns.Count).End(xlToLeft).Column
     If IsEmpty(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value) Then
        MsgBox "Postoji Sheet AllSheets, ali nema imena kolona. Unesite nazive kolona!"
        End
     End If
     If LC1 = 1 Then
          r2 = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
          ReDim Arr(0 To Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Count) ' redim array size to 1 (only 1 cell in range)
        Arr(0) = r2
     Else
    Arr = Application.Transpose(Application.Transpose(Master.Range(Master.Cells(1, 1), Master.Cells(1, LC1)).Value))
    End If
    
  End If
 
For Each ws In ActiveWorkbook.Sheets
    If ws.Name <> "AllSheets" Then
    
    For i = LBound(Arr) To UBound(Arr)
        LC2 = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
         Set Found = ws.Range(ws.Cells(1, 1), ws.Cells(1, LC2)).Find(Arr(i), LookIn:=xlValues)
        
            If Not Found Is Nothing Then
             If LC1 = 1 Then
                LR1 = Master.Cells(Master.Rows.Count, i + 1).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i + 1).PasteSpecial xlPasteValues
                    With Master.Columns(1)
                      .EntireColumn.AutoFit
                    End With
                    
                Else
                LR1 = Master.Cells(Master.Rows.Count, i).End(xlUp).Offset(1).Row
                LR2 = ws.Cells(ws.Rows.Count, Found.Column).End(xlUp).Row
                ws.Range(ws.Cells(2, Found.Column), ws.Cells(LR2, Found.Column)).Copy
                    Master.Cells(LR1, i).PasteSpecial xlPasteValues
                    With Master.Columns(i)
                      .EntireColumn.AutoFit
                    End With
                End If
            
            End If
    Next i
    End If
    
Next ws
End Sub

but i have one more problem. if my column have blank cell. the copying does not works. my current situation is
sheet 1, sheet 2 and allsheets. i want situation like on allsheets-1

 

[gogi100]

If the last cell is empty in the column, which is copied to the Allsheets, after copying the data from the second sheet, it does not remain empty but is filled.