1

Sub CombineMappedExcelFiles()

   Dim wsMaster As Worksheet
   Dim wsMapping As Worksheet
   Dim mappingDict As Object
   Dim headerDict As Object
   Dim fDialog As FileDialog
   Dim folderPath As String
   Dim fileName As String
   Dim wbTemp As Workbook
   Dim wsTemp As Worksheet
   Dim sourceHeader As String, targetHeader As String
   Dim colMap As Object
   Dim i As Long, j As Long
   Dim lastCol As Long, lastRow As Long
   Dim pasteRow As Long
   Dim headerIndex As Long
   Dim keyIndex As Long
   Dim keyArray As Variant

   Application.ScreenUpdating = False
   Application.DisplayAlerts = False

   Set wsMaster = ThisWorkbook.Sheets("Sheet1")
   Set wsMapping = ThisWorkbook.Sheets("Mapping")

   ' Read mapping into dictionary: source column → target column
   Set mappingDict = CreateObject("Scripting.Dictionary")
   i = 2 ' Assuming header in row 1
   Do While wsMapping.Cells(i, 1).Value <> ""
       sourceHeader = Trim(wsMapping.Cells(i, 1).Value)
       targetHeader = Trim(wsMapping.Cells(i, 2).Value)
       If sourceHeader <> "" And targetHeader <> "" Then
           mappingDict(sourceHeader) = targetHeader
       End If
       i = i + 1
   Loop

   ' Read target headers from Sheet1 row 1 and build headerDict: target column → column number
   Set headerDict = CreateObject("Scripting.Dictionary")
   lastCol = wsMaster.Cells(1, wsMaster.Columns.Count).End(xlToLeft).Column
   For i = 1 To lastCol
       header = Trim(wsMaster.Cells(1, i).Value)
       If header <> "" Then headerDict(header) = i
   Next i

   ' Prompt user to select folder
   Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
   With fDialog
       .Title = "Select Folder Containing Excel Files"
       If .Show <> -1 Then Exit Sub
       folderPath = .SelectedItems(1) & "\"
   End With

   ' Find first empty row in Sheet1 to start appending
   pasteRow = wsMaster.Cells(wsMaster.Rows.Count, 1).End(xlUp).Row + 1

   ' Loop through all Excel files
   fileName = Dir(folderPath & "*.xls*")
   Do While fileName <> ""
       Set wbTemp = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
       Set wsTemp = wbTemp.Sheets(1)

       ' Build column map from source to destination column numbers
       Set colMap = CreateObject("Scripting.Dictionary")
       lastCol = wsTemp.Cells(1, wsTemp.Columns.Count).End(xlToLeft).Column
       For i = 1 To lastCol
           sourceHeader = Trim(wsTemp.Cells(1, i).Value)
           If mappingDict.exists(sourceHeader) Then
               targetHeader = mappingDict(sourceHeader)
               If headerDict.exists(targetHeader) Then
                   colMap(i) = headerDict(targetHeader)
               End If
           End If
       Next i

       ' Copy data row-wise
       lastRow = wsTemp.Cells(wsTemp.Rows.Count, 1).End(xlUp).Row
       For i = 2 To lastRow
           ' Add source filename in column A (assumes A is for source file)
           wsMaster.Cells(pasteRow, 1).Value = fileName

           keyArray = colMap.Keys
           For keyIndex = LBound(keyArray) To UBound(keyArray)
               j = keyArray(keyIndex)
               headerIndex = colMap(j)
               wsMaster.Cells(pasteRow, headerIndex).Value = wsTemp.Cells(i, j).Value
           Next keyIndex

           pasteRow = pasteRow + 1
       Next i

       wbTemp.Close False
       fileName = Dir
   Loop

   Application.ScreenUpdating = True
   Application.DisplayAlerts = True

   MsgBox "Data combined successfully using mapping!", vbInformation

End Sub