VBA code to copy paste data from multiple source workbooks to a master data workbook (Master data sheet) based on column headers

Since the order of the columns is different you have to copy them one at a time.

Sub ImportExcelfiles() Const ROW_COLNAME = 3 'Variables for Sheet - Workbook Name Dim wbSource As Workbook Dim wsTarget As Worksheet, wsName As Worksheet Dim rowOutputTarget As Long, nameCount As Long Dim strPath As String, strFile As String, fileName As String With ThisWorkbook 'set the file and path to folder strPath = .Sheets("Control").Range("C4") fileName = .Sheets("Control").Range("C5") If Right(strPath, 1) <> "\" Then strPath = strPath & "\" 'set the target and name worksheets Set wsTarget = .Sheets("Master Data") Set wsName = .Sheets("Workbook Name") End With ' fill dictionary column name to column number from row 1 Dim dict As Object, k As String, rng As Range Dim lastcol As Long, lastrow As Long, i As Long, n As Long Set dict = CreateObject("Scripting.Dictionary") With wsTarget lastcol = .Cells(1, .Columns.Count).End(xlToLeft).Column For i = 1 To lastcol k = UCase(Trim(.Cells(1, i))) dict.Add k, i Next End With 'set the initial output row and column count for master data and workbook nam rowOutputTarget = 2 nameCount = 2 'get the first file strFile = Dir(strPath & "*.xlsx*") 'loop through the excel files in the folder Dim ar, arH, ky, bHasData Application.ScreenUpdating = False Do While strFile <> "" If InStr(strFile, fileName) > 0 Then 'open the workbook Set wbSource = Workbooks.Open(strPath & strFile, False, False) wsName.Range("A" & nameCount).Value = wbSource.Name nameCount = nameCount + 1 ' copy values to arrays With wbSource.Sheets("Details") lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row arH = .Range("A1:AD1").Offset(ROW_COLNAME - 1).Value2 ' col names ar = .Range("A" & ROW_COLNAME & ":AD" & lastrow).Value2 End With 'close the opened workbook wbSource.Close SaveChanges:=False ' copy each columns If lastrow > ROW_COLNAME Then bHasData = False For n = 1 To UBound(ar, 2) k = UCase(Trim(arH(1, n))) ' determine target column using dictonary ' as lookup with approx match i = 0 For Each ky In dict If InStr(1, k, ky) > 0 Then i = dict(ky) Exit For End If Next ' valid match If i > 0 Then bHasData = True Set rng = wsTarget.Cells(rowOutputTarget, i).Resize(UBound(ar)) ' copy column n of array to column i of target sheet rng.Value2 = Application.Index(ar, 0, n) ElseIf Len(k) > 0 Then Debug.Print "Column '" & k & "' not found " & strFile End If Next If bHasData Then rowOutputTarget = rowOutputTarget + UBound(ar) + 2 End If End If 'get the next file strFile = Dir() End If Loop Application.ScreenUpdating = True MsgBox nameCount - 2 & " books", vbInformation End Sub 

Import Data From Files in Folder

Option Explicit Sub ImportExcelfiles() ' Source Const sName As String = "Details" Const siFileExtensionPattern As String = ".xlsx" ' maybe ".xls?" ? Const sfCol As String = "A" Const slCol As String = "AD" Const sfRow As Long = 3 ' Destination Const dName As String = "Master Data" Const dfCellAddress As String = "A2" ' Destination Lookup Const dlName As String = "Control" Const dlsFolderPathAddress As String = "C4" Const dlsFileNamePatternAddress As String = "C5" ' Destination Name Const dnName As String = "Workbook Name" Const dnfCellAddress As String = "A2" Dim dwb As Workbook: Set dwb = ThisWorkbook ' Destination Lookup Worksheet ' (contains the folder path and the partial file name) Dim dlws As Worksheet: Set dlws = dwb.Worksheets(dlName) Dim sFolderPath As String: sFolderPath = dlws.Range(dlsFolderPathAddress) If Right(sFolderPath, 1) <> "\" Then sFolderPath = sFolderPath & "\" Dim sFileNamePattern As String ' contains i.e. leading and trailing '*' sFileNamePattern = "*" & dlws.Range(dlsFileNamePatternAddress) & "*" Dim sFileExtensionPattern As String sFileExtensionPattern = siFileExtensionPattern If Left(sFileExtensionPattern, 1) <> "." Then _ sFileExtensionPattern = "." & sFileExtensionPattern Dim sFileName As String sFileName = Dir(sFolderPath & sFileNamePattern & sFileExtensionPattern) If Len(sFileName) = 0 Then MsgBox "No files found.", vbCritical ' improve! Exit Sub End If ' Destination Worksheet (source data will by copied to) Dim dws As Worksheet: Set dws = dwb.Worksheets(dName) ' Source and Destination Columns Count Dim cCount As Long cCount = dws.Columns(slCol).Column - dws.Columns(sfCol).Column + 1 ' Destination First Row Range Dim dfrrg As Range: Set dfrrg = dws.Range(dfCellAddress).Resize(, cCount) ' Destination Name Worksheet (source workbook names will be written to) Dim dnws As Worksheet: Set dnws = dwb.Worksheets(dnName) ' Destination Name Cell Dim dnCell As Range: Set dnCell = dnws.Range(dnfCellAddress) Application.ScreenUpdating = False ' Source Dim swb As Workbook Dim sws As Worksheet Dim srg As Range Dim slRow As Long ' Destination Dim drg As Range ' Both Dim rCount As Long Do While Len(sFileName) > 0 Set swb = Workbooks.Open(sFolderPath & sFileName) ' Attempt to reference the source worksheet. On Error Resume Next Set sws = swb.Worksheets("Details") On Error GoTo 0 If Not sws Is Nothing Then ' worksheet exists slRow = sws.Cells(sws.Rows.Count, sfCol).End(xlUp).Row If slRow >= sfRow Then ' found data in column rCount = slRow - sfRow + 1 Set srg = sws.Cells(sfRow, sfCol).Resize(rCount, cCount) Set drg = dfrrg.Resize(rCount) drg.Value = srg.Value dnCell.Value = swb.Name ' Reset Set dfrrg = dfrrg.Offset(rCount) Set dnCell = dnCell.Offset(1) 'Else ' found no data in column; do nothing End If Set sws = Nothing 'Else ' worksheet doesn't exist; do nothing End If swb.Close SaveChanges:=False sFileName = Dir Loop Application.ScreenUpdating = True MsgBox "Data imported.", vbInformation End Sub