Merge files and remap columns using SQL

Tested in Excel 365 (16.8730.2046) 64-bit

You might have an old macro that is processing raw files with a certain format and someone decided to change that format.. Here is a solution to remap those columns.

It’s fast because it uses SQL but is also sensitive because it uses Microsoft.ACE.OLEDB.12.0, hence looking at the first 8 rows to decide the data type for each column. After digging a lot of forums and trying a lot of mentioned solutions, I decide to use a workaround: insert a first row with dummy text for text columns to force the correct result.

Another thing to pay attention is filtering the data: blank cells are considered NULL so they need to be transformed to empty string to have a correctly filtered data (see Iif function). CStr is not an option because it errs when it comes to NULL.

I used 2 setting tables:

FileSettings

and ColumnSettings

The code looks like this:

 
 
  1. Option Explicit
  2. Public Const dummyVal = "d832#023#093ryrfw#2sgweg"
  3. Public Const SettingsSheet = "Settings"
  4. Public Const HomeSheet = "Home"
  5. Public Const DataSheet = "Data"
  6. Public Const FileSettings = "FileSettings"
  7. Public Const ColumnSettings = "ColumnSettings"
  8. Public DestinationSheet
  9. Public SourceSheet
  10. Public DestinationHeaderRow
  11. Public SourceHeaderRow
  12. '======================================================
  13. Sub ImportData()
  14.     Dim myFile, arrFiles
  15.     Dim i
  16.     Dim tbl As ListObject
  17.     Dim FirstPasteRow
  18.     Dim myWkb, extWkb, tmpSh, extSheet
  19.    
  20.     ToggleExcelFunctionalities False
  21.     Call LoadSettings
  22.    
  23.     Set myWkb = ActiveWorkbook
  24.     Set tbl = Sheets(SettingsSheet).ListObjects(ColumnSettings)
  25.    
  26.     If SheetExists(DestinationSheet) Then
  27.         If MsgBox("The sheet '" & DestinationSheet & "' already exists!" & vbCr & _
  28.             "Do you want to append to it?" & vbCr & _
  29.             "If you click No the existing data will be overwritten!", vbYesNo, "Attention!") = vbNo Then
  30.             Sheets(DestinationSheet).Delete
  31.             Sheets.Add after:=Sheets(Sheets.Count)
  32.             ActiveSheet.Name = DestinationSheet
  33.         End If
  34.     Else
  35.         Sheets.Add after:=Sheets(Sheets.Count)
  36.         ActiveSheet.Name = DestinationSheet
  37.     End If
  38.    
  39.     ' add header if not already there
  40.    Sheets(DestinationSheet).Select
  41.     FirstPasteRow = LastRowOrCol(0, 1, 5) + 1
  42.     If FirstPasteRow - 1 <= DestinationHeaderRow Then
  43.         FirstPasteRow = DestinationHeaderRow + 1
  44.         For i = 1 To tbl.DataBodyRange.Rows.Count
  45.             Cells(DestinationHeaderRow, i).Value = tbl.DataBodyRange(i, 1).Value
  46.         Next i
  47.         Cells(1, tbl.DataBodyRange.Rows.Count + 1).Value = "Source"
  48.     End If
  49.    
  50.     ' get the files to be processed
  51.    myFile = PickFileOrFolder(1, 1)
  52.     arrFiles = Split(myFile, "|")
  53.     ' process the files
  54.    For i = 0 To UBound(arrFiles) - 1
  55.         Set extWkb = Workbooks.Open(arrFiles(i))
  56.         extWkb.Activate
  57.         tmpSh = SourceSheet
  58.         If tmpSh = 1 Then tmpSh = Sheets(SourceSheet).Name
  59.         If SheetExists(tmpSh) Then
  60.             Sheets(tmpSh).Select
  61.             ' make header the first row
  62.            If SourceHeaderRow > 1 Then Rows(1 & ":" & SourceHeaderRow - 1).Delete
  63.             ' remap cols
  64.            Set extSheet = extWkb.Sheets(tmpSh)
  65.             myWkb.Activate
  66.             RemapData extSheet, FirstPasteRow
  67.             FirstPasteRow = LastRowOrCol(0, 1, 5) + 1
  68.             extWkb.Close
  69.         End If
  70.     Next i
  71.    
  72.     ToggleExcelFunctionalities True
  73.     MsgBox "Done!"
  74. End Sub
  75. Sub LoadSettings()
  76.     Dim tbl As ListObject, i
  77.     Set tbl = Sheets(SettingsSheet).ListObjects(FileSettings)
  78.    
  79.     For i = 1 To tbl.DataBodyRange.Rows.Count
  80.         If tbl.DataBodyRange(i, 1).Value = "Sheet" Then
  81.             DestinationSheet = tbl.DataBodyRange(i, 2).Value
  82.             SourceSheet = tbl.DataBodyRange(i, 3).Value
  83.         Else
  84.             DestinationHeaderRow = tbl.DataBodyRange(i, 2).Value
  85.             SourceHeaderRow = tbl.DataBodyRange(i, 3).Value
  86.         End If
  87.     Next i
  88.    
  89.     If DestinationSheet = "" Then DestinationSheet = "Results"
  90.     If SourceSheet = "" Then SourceSheet = 1
  91. End Sub
  92. Sub RemapData(WorkbookAndSheet, FirstPasteRow)
  93.     Dim rs As Recordset, sSQL As String
  94.     Dim i
  95.     Dim tbl As ListObject
  96.     Dim LastTextCol, LastRow
  97.    
  98.     ' prepare text columns
  99.    WorkbookAndSheet.Activate
  100.     Set tbl = ThisWorkbook.Sheets(SettingsSheet).ListObjects(ColumnSettings)
  101.     WorkbookAndSheet.Activate
  102.     Rows("2:2").Insert Shift:=xlDown
  103.     For i = 1 To tbl.DataBodyRange.Rows.Count
  104.         If tbl.DataBodyRange(i, 4).Value = "Text" Then
  105.             Cells(2, i).Value = dummyVal
  106.             LastTextCol = Cells(1, i)
  107.         End If
  108.     Next i
  109.    
  110.     ' create sql string
  111.    sSQL = "select "
  112.     For i = 1 To tbl.DataBodyRange.Rows.Count
  113.         Select Case True
  114.             Case tbl.DataBodyRange(i, 2).Value <> ""
  115.             ' there is a column to map
  116.                sSQL = sSQL & "[" & tbl.DataBodyRange(i, 2).Value & "] as [" & tbl.DataBodyRange(i, 1).Value & "],"
  117.            
  118.             Case tbl.DataBodyRange(i, 3).Value <> ""
  119.             ' a fixed value should be copied
  120.                sSQL = sSQL & "'" & tbl.DataBodyRange(i, 3).Value & "' as [" & tbl.DataBodyRange(i, 1).Value & "],"
  121.            
  122.             Case Else
  123.             ' a blank col should be created
  124.                sSQL = sSQL & "'' as [" & tbl.DataBodyRange(i, 1).Value & "],"
  125.        
  126.         End Select
  127.     Next i
  128.    
  129.     sSQL = Left(sSQL, Len(sSQL) - 1) ' remove extra comma
  130.    sSQL = sSQL & " from [" & WorkbookAndSheet.Name & "$] "
  131.     If LastTextCol <> "" Then sSQL = sSQL & "where iif(isnull([" & LastTextCol & "]),'',[" & LastTextCol & "] )<>'" & dummyVal & "'"
  132.        
  133.     Set rs = RangeToRecordset2(ActiveWorkbook.FullName, sSQL)
  134.    
  135.     ' paste data
  136.    ThisWorkbook.Activate
  137.     Sheets(DestinationSheet).Select
  138.     Cells(FirstPasteRow, 1).CopyFromRecordset rs
  139.        
  140.     ' add source
  141.    Range(Cells(FirstPasteRow, rs.Fields.Count + 1), Cells(FirstPasteRow + rs.RecordCount - 1, rs.Fields.Count + 1)).Value = _
  142.                 WorkbookAndSheet.Parent.FullName
  143.     Set rs = Nothing
  144.    
  145. End Sub

The functions used here can be found on: LastRowOrCol, RangeToRecordset2, PickFileOrFolder, SheetExistsToggleExcelFunctionalities