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:
- Option Explicit
- Public Const dummyVal = "d832#023#093ryrfw#2sgweg"
- Public Const SettingsSheet = "Settings"
- Public Const HomeSheet = "Home"
- Public Const DataSheet = "Data"
- Public Const FileSettings = "FileSettings"
- Public Const ColumnSettings = "ColumnSettings"
- Public DestinationSheet
- Public SourceSheet
- Public DestinationHeaderRow
- Public SourceHeaderRow
- '======================================================
- Sub ImportData()
- Dim myFile, arrFiles
- Dim i
- Dim tbl As ListObject
- Dim FirstPasteRow
- Dim myWkb, extWkb, tmpSh, extSheet
- ToggleExcelFunctionalities False
- Call LoadSettings
- Set myWkb = ActiveWorkbook
- Set tbl = Sheets(SettingsSheet).ListObjects(ColumnSettings)
- If SheetExists(DestinationSheet) Then
- If MsgBox("The sheet '" & DestinationSheet & "' already exists!" & vbCr & _
- "Do you want to append to it?" & vbCr & _
- "If you click No the existing data will be overwritten!", vbYesNo, "Attention!") = vbNo Then
- Sheets(DestinationSheet).Delete
- Sheets.Add after:=Sheets(Sheets.Count)
- ActiveSheet.Name = DestinationSheet
- End If
- Else
- Sheets.Add after:=Sheets(Sheets.Count)
- ActiveSheet.Name = DestinationSheet
- End If
- ' add header if not already there
- Sheets(DestinationSheet).Select
- FirstPasteRow = LastRowOrCol(0, 1, 5) + 1
- If FirstPasteRow - 1 <= DestinationHeaderRow Then
- FirstPasteRow = DestinationHeaderRow + 1
- For i = 1 To tbl.DataBodyRange.Rows.Count
- Cells(DestinationHeaderRow, i).Value = tbl.DataBodyRange(i, 1).Value
- Next i
- Cells(1, tbl.DataBodyRange.Rows.Count + 1).Value = "Source"
- End If
- ' get the files to be processed
- myFile = PickFileOrFolder(1, 1)
- arrFiles = Split(myFile, "|")
- ' process the files
- For i = 0 To UBound(arrFiles) - 1
- Set extWkb = Workbooks.Open(arrFiles(i))
- extWkb.Activate
- tmpSh = SourceSheet
- If tmpSh = 1 Then tmpSh = Sheets(SourceSheet).Name
- If SheetExists(tmpSh) Then
- Sheets(tmpSh).Select
- ' make header the first row
- If SourceHeaderRow > 1 Then Rows(1 & ":" & SourceHeaderRow - 1).Delete
- ' remap cols
- Set extSheet = extWkb.Sheets(tmpSh)
- myWkb.Activate
- RemapData extSheet, FirstPasteRow
- FirstPasteRow = LastRowOrCol(0, 1, 5) + 1
- extWkb.Close
- End If
- Next i
- ToggleExcelFunctionalities True
- MsgBox "Done!"
- End Sub
- Sub LoadSettings()
- Dim tbl As ListObject, i
- Set tbl = Sheets(SettingsSheet).ListObjects(FileSettings)
- For i = 1 To tbl.DataBodyRange.Rows.Count
- If tbl.DataBodyRange(i, 1).Value = "Sheet" Then
- DestinationSheet = tbl.DataBodyRange(i, 2).Value
- SourceSheet = tbl.DataBodyRange(i, 3).Value
- Else
- DestinationHeaderRow = tbl.DataBodyRange(i, 2).Value
- SourceHeaderRow = tbl.DataBodyRange(i, 3).Value
- End If
- Next i
- If DestinationSheet = "" Then DestinationSheet = "Results"
- If SourceSheet = "" Then SourceSheet = 1
- End Sub
- Sub RemapData(WorkbookAndSheet, FirstPasteRow)
- Dim rs As Recordset, sSQL As String
- Dim i
- Dim tbl As ListObject
- Dim LastTextCol, LastRow
- ' prepare text columns
- WorkbookAndSheet.Activate
- Set tbl = ThisWorkbook.Sheets(SettingsSheet).ListObjects(ColumnSettings)
- WorkbookAndSheet.Activate
- Rows("2:2").Insert Shift:=xlDown
- For i = 1 To tbl.DataBodyRange.Rows.Count
- If tbl.DataBodyRange(i, 4).Value = "Text" Then
- Cells(2, i).Value = dummyVal
- LastTextCol = Cells(1, i)
- End If
- Next i
- ' create sql string
- sSQL = "select "
- For i = 1 To tbl.DataBodyRange.Rows.Count
- Select Case True
- Case tbl.DataBodyRange(i, 2).Value <> ""
- ' there is a column to map
- sSQL = sSQL & "[" & tbl.DataBodyRange(i, 2).Value & "] as [" & tbl.DataBodyRange(i, 1).Value & "],"
- Case tbl.DataBodyRange(i, 3).Value <> ""
- ' a fixed value should be copied
- sSQL = sSQL & "'" & tbl.DataBodyRange(i, 3).Value & "' as [" & tbl.DataBodyRange(i, 1).Value & "],"
- Case Else
- ' a blank col should be created
- sSQL = sSQL & "'' as [" & tbl.DataBodyRange(i, 1).Value & "],"
- End Select
- Next i
- sSQL = Left(sSQL, Len(sSQL) - 1) ' remove extra comma
- sSQL = sSQL & " from [" & WorkbookAndSheet.Name & "$] "
- If LastTextCol <> "" Then sSQL = sSQL & "where iif(isnull([" & LastTextCol & "]),'',[" & LastTextCol & "] )<>'" & dummyVal & "'"
- Set rs = RangeToRecordset2(ActiveWorkbook.FullName, sSQL)
- ' paste data
- ThisWorkbook.Activate
- Sheets(DestinationSheet).Select
- Cells(FirstPasteRow, 1).CopyFromRecordset rs
- ' add source
- Range(Cells(FirstPasteRow, rs.Fields.Count + 1), Cells(FirstPasteRow + rs.RecordCount - 1, rs.Fields.Count + 1)).Value = _
- WorkbookAndSheet.Parent.FullName
- Set rs = Nothing
- End Sub
The functions used here can be found on: LastRowOrCol, RangeToRecordset2, PickFileOrFolder, SheetExists, ToggleExcelFunctionalities