Prepare report files for SQL upload

Tested in Excel 365 (16.8730.2046) 64-bit

Sometimes you have a set of files containing sheets with crosstabs that you need to further process in SQL server for example.

Because they are crosstabs, some information is summarized either as page title, table title or table info, see example below, click to see full size.

Click to enlarge

In this case you would need to add this summarized information as new columns. It can be easily done using formula if it’s only one file (see here how) but when you have hundreds, you could use some VBA code.

I used this file (no macros) to build the macros.

Jump to

Declarations

 
 
  1. Public TableHeaderDelimiter As String

Functions

FindDelimiter

GetAddressPart

GetRangeSize

 
 
  1. Public Function GetRangeSize(RangeToCheck As String)
  2.     On Error GoTo err_return
  3.    
  4.     If RangeToCheck = "" Then
  5.         GetRangeSize = 0
  6.     Else
  7.         GetRangeSize = Range(RangeToCheck).Count
  8.     End If
  9.    
  10. exit_function:
  11.     Exit Function
  12. err_return:
  13.     GetRangeSize = -1
  14. End Function

LastRowOrCol

PickFileOrFolder

SheetExists

Helper sub

ToggleExcelFunctionalities

Main subs

A sub to get the parameters needed for the transformation sub that should be assigned to the Select button.

 
 
  1. Sub UserSettings()
  2.     Dim a, b, c As String
  3.     Dim rng As Range, strMsgBox As String
  4.     Dim myWkb As Workbook
  5.    
  6.     Set a = Application
  7.     Set myWkb = ActiveWorkbook
  8.    
  9.     Select Case ActiveCell.Address
  10.         Case "$B$2" ' Folder containing the files*
  11.            Cells(2, 2).Value = PickFileOrFolder(0)
  12.         Case "$B$3" ' Destination folder
  13.            Cells(3, 2).Value = PickFileOrFolder(0)
  14.         Case "$B$4" ' Page Title Names
  15.            b = "Select the range containing the Page Title Names. It should be a single column, one or more rows."
  16.             c = a.InputBox(b, , , , , , , 0)
  17.             If Range(GetAddressPart(c)).Columns.Count > 1 Then
  18.                 strMsgBox = "- It should be a single column, one or more rows."
  19.                 Cells(4, 2).ClearContents
  20.             Else
  21.                 Cells(4, 2).Value = GetAddressPart(c)
  22.             End If
  23.             If Cells(4, 2).Value <> "" And Cells(5, 2).Value <> "" Then
  24.                 If Range(Cells(4, 2).Value).Count <> Range(Cells(5, 2).Value).Count Then
  25.                     strMsgBox = strMsgBox & vbCr & "- Ranges for values and names should be the same size."
  26.                     Cells(4, 2).ClearContents
  27.                 End If
  28.             End If
  29.             If strMsgBox <> "" Then
  30.                 strMsgBox = strMsgBox & vbCr & "Try again!"
  31.                 MsgBox strMsgBox
  32.             End If
  33.         Case "$B$5" ' Page Title Values
  34.            b = "Select the range containing the Page Title Values. It should be a single column, one or more rows."
  35.             c = a.InputBox(b, , , , , , , 0)
  36.             If Range(GetAddressPart(c)).Columns.Count > 1 Then
  37.                 strMsgBox = "- It should be a single column, one or more rows."
  38.                 Cells(5, 2).ClearContents
  39.             Else
  40.                 Cells(5, 2).Value = GetAddressPart(c)
  41.             End If
  42.             If Cells(4, 2).Value <> "" And Cells(5, 2).Value <> "" Then
  43.                 If Range(Cells(4, 2).Value).Count <> Range(Cells(5, 2).Value).Count Then
  44.                     strMsgBox = strMsgBox & vbCr & "- Ranges for values and names should be the same size."
  45.                     Cells(5, 2).ClearContents
  46.                 End If
  47.             End If
  48.             If strMsgBox <> "" Then
  49.                 strMsgBox = strMsgBox & vbCr & "Try again!"
  50.                 MsgBox strMsgBox
  51.             End If
  52.         Case "$B$6" ' Table Title
  53.            b = "Select the range containing the Table Titles. It should be a single column, one or more rows."
  54.             c = a.InputBox(b, , , , , , , 0)
  55.             If Range(GetAddressPart(c)).Columns.Count > 1 Then
  56.                 MsgBox "It should be a single column, one or more rows! Try again."
  57.                 Cells(6, 2).ClearContents
  58.             Else
  59.                 Cells(6, 2).Value = GetAddressPart(c)
  60.             End If
  61.         Case "$B$7" ' Table Header
  62.            b = "Select the range containing the Table Header. It should be a single row."
  63.             c = a.InputBox(b, , , , , , , 0)
  64.             If Range(GetAddressPart(c)).Rows.Count > 1 Then
  65.                 MsgBox "It should be a single row! Try again."
  66.                 Cells(7, 2).ClearContents
  67.             Else
  68.                 Cells(7, 2).Value = GetAddressPart(c)
  69.                 ' Table Header values
  70.                TableHeaderDelimiter = FindDelimiter(Range(GetAddressPart(c)))
  71.                 Set rng = Workbooks(GetAddressPart(c, "w")).Sheets(GetAddressPart(c, "s")).Range(GetAddressPart(c, "r"))
  72.                 Cells(8, 2).Value = Join(a.Transpose(a.Transpose(rng)), TableHeaderDelimiter) & TableHeaderDelimiter
  73.             End If
  74.         Case "$B$9" ' Table Info
  75.            b = "Select the range containing the Table Info. It should be a single cell."
  76.             c = a.InputBox(b, , , , , , , 0)
  77.             If Range(GetAddressPart(c)).Columns.Count > 1 Or Range(GetAddressPart(c)).Rows.Count > 1 Then
  78.                 MsgBox "It should be a single cell! Try again."
  79.                 Cells(9, 2).ClearContents
  80.             Else
  81.                 Cells(9, 2).Value = GetAddressPart(c)
  82.             End If
  83.         Case Else
  84.     End Select
  85.    
  86.     Cells(ActiveCell.Row + 1, 2).Select
  87. End Sub

The main sub that would process the files. The sub should be assigned to the Process Files button.

 
 
  1. ' need to add the following reference:
  2. ' Microsoft Scripting Runtime
  3.    Dim fso As New FileSystemObject, folder As Variant, file As Variant
  4.     Dim SourcePath As String, DestinationPath
  5.     Dim myWkb As Workbook, extWkb As Workbook
  6.     Dim SettingsArray(7), a, i, j, k, LastRow, LastCol
  7.     Dim RngPage As Range, RngTitle As Range, RngInfo As Range, tempRng As Range
  8.     Dim tempDelim As String, tempArr As Variant, arrPageName As Variant, arrPageValue As Variant
  9.     Dim crtTableHeader As String, crtTableInfo As String, TtThDistance, TtTiDistance
  10.     Dim PageTitleSize, TableTitleSize, TableInfoSize
  11.     Dim PageTitleName0 As String, PageTitleValue0 As String, TableTitle0 As String, TableHeader0 As String
  12.     Dim TableHeaderValue0 As String, TableInfo0 As String, TableInfoDelim0 As String, TableInfoCols0, TableInfoCols
  13.     Dim SheetStatus As String, arrStatus(), arrRow
  14.    
  15.     Call ToggleExcelFunctionalities(False)
  16.     Set a = Application
  17.    
  18.     '1) check if the provided info is ok
  19.    ' check if the folder containing the files is specified
  20.    If InStr(1, Cells(2, 2).Value, "\") > 0 Then
  21.         SourcePath = Cells(2, 2).Value
  22.     Else
  23.         MsgBox "Select first the folder containing the files!"
  24.         Exit Sub
  25.     End If
  26.    
  27.     ' determine the destination folder
  28.    If InStr(1, Cells(3, 2).Value, "\") > 0 Then
  29.         DestinationPath = Cells(3, 2).Value
  30.     Else
  31.         If Len(Trim(Cells(3, 2).Value)) = 0 Then
  32.             DestinationPath = SourcePath & "\" & "Processed"
  33.         Else
  34.             DestinationPath = SourcePath & "\" & Cells(3, 2).Value
  35.         End If
  36.     End If
  37.    
  38.     '2) get the params from the setting tab
  39.    For i = 0 To UBound(SettingsArray)
  40.         SettingsArray(i) = Cells(i + 4, 2).Value
  41.     Next i
  42.     PageTitleName0 = SettingsArray(0)
  43.     PageTitleValue0 = SettingsArray(1)
  44.     TableTitle0 = SettingsArray(2)
  45.     TableHeader0 = SettingsArray(3)
  46.     TableHeaderValue0 = SettingsArray(4)
  47.     TableInfo0 = SettingsArray(5)
  48.     TableInfoDelim0 = SettingsArray(6)
  49.     TableInfoCols0 = SettingsArray(7)
  50.     PageTitleSize = GetRangeSize(PageTitleName0)
  51.     TableTitleSize = GetRangeSize(TableTitle0)
  52.     If TableInfoCols0 = "" Then
  53.         TableInfoCols = -1
  54.     Else
  55.         TableInfoCols = CInt(TableInfoCols0)
  56.     End If
  57.    
  58.     ' check for table header and find the delimiter
  59.    If TableHeaderValue0 <> "" Then
  60.         TableHeaderDelimiter = Right(TableHeaderValue0, 1)
  61.     Else
  62.         MsgBox "Table header is missing. Please select it first!"
  63.         Exit Sub
  64.     End If
  65.    
  66.     ' get the distance between table title and table header
  67.    If TableTitle0 <> "" And TableHeader0 <> "" Then
  68.         TtThDistance = Range(TableHeader0).Row - Range(TableTitle0).Row
  69.     Else
  70.         TtThDistance = 0
  71.     End If
  72.    
  73.     ' get the distance between table info and table header
  74.    If TableInfo0 <> "" And TableHeader0 <> "" Then
  75.         TtTiDistance = Range(TableHeader0).Row - Range(TableInfo0).Row
  76.     Else
  77.         TtTiDistance = 0
  78.     End If
  79.    
  80.     'prepare the summary array
  81.    ReDim Preserve arrStatus(2, 0)
  82.    
  83.     '3) prepare the loop through files
  84.    Set fso = CreateObject("Scripting.FileSystemObject")
  85.    
  86.     If fso.FolderExists(SourcePath) Then
  87.         Set folder = fso.GetFolder(SourcePath)
  88.     Else
  89.         MsgBox "Source Folder doesn't exist!", vbCritical, "Warning"
  90.         Exit Sub
  91.     End If
  92.     ' create the destination folder if missing
  93.    If Not fso.FolderExists(DestinationPath) Then MkDir DestinationPath
  94.    
  95.     Set myWkb = ActiveWorkbook
  96.    
  97.     '4) loop through files
  98.    For Each file In folder.Files
  99. '        Debug.Print file.Path, file.Name
  100.        Workbooks.Open Filename:=file.Path
  101.         Set extWkb = ActiveWorkbook
  102.         '4a) loop through all sheets
  103.        For i = 1 To Sheets.Count
  104.             Sheets(i).Activate
  105.             ' check if the format is right by checking the first table header
  106.            crtTableHeader = Join(a.Transpose(a.Transpose(Range(TableHeader0).Value)), TableHeaderDelimiter) & TableHeaderDelimiter
  107.             If crtTableHeader = TableHeaderValue0 Then  ' if the same header, process the sheet
  108.                LastRow = LastRowOrCol(0, 1, 10)
  109.                 LastCol = LastRowOrCol(1, 1, 20)
  110.                
  111.                 ' store page title
  112.                If PageTitleValue0 <> "" Then
  113.                     arrPageName = Range(PageTitleName0)
  114.                     arrPageValue = Range(PageTitleValue0)
  115.                 End If
  116.                
  117.                 ' copy the table header on the first row
  118.                Range(Cells(1, Range(TableHeader0).Column), _
  119.                     Cells(1, Range(TableHeader0).Column + Range(TableHeader0).Count - 1)).Value = _
  120.                     Range(TableHeader0).Value
  121.                        
  122.                 ' page title names as column names
  123.                If PageTitleName0 <> "" Then _
  124.                     Range(Cells(1, LastCol + 1), Cells(1, LastCol + PageTitleSize)) = a.Transpose(arrPageName)
  125.                
  126.                 ' find the table info paste size
  127.                If TableInfoDelim0 <> "" And TableInfo0 <> "" Then
  128.                     tempArr = Split(Range(TableInfo0).Value, TableInfoDelim0, TableInfoCols)
  129.                     TableInfoSize = UBound(tempArr) + 1
  130.                 Else
  131.                     TableInfoSize = 1
  132.                 End If
  133.                
  134.                 ' first table title range
  135.                If TableTitle0 <> "" Then Set RngTitle = Range(TableTitle0)
  136.                 ' first table info range
  137.                If TableInfo0 <> "" Then Set RngInfo = Range(TableInfo0)
  138.                
  139.                 '4b) loop through all rows
  140.                For j = 2 To LastRow
  141.                     '5a) page title values
  142.                    If PageTitleValue0 <> "" Then _
  143.                         Range(Cells(j, LastCol + 1), Cells(j, LastCol + PageTitleSize)) = a.Transpose(arrPageValue)
  144.                    
  145.                     '5b) table title
  146.                    If TableTitle0 <> "" Then
  147.                         ' check if the current row contains a new table title by verifying
  148.                        ' if table header is on the expected position
  149.                        Set tempRng = Range(Cells(j + TtThDistance, Range(TableHeader0).Column), _
  150.                         Cells(j + TtThDistance, Range(TableHeader0).Column + Range(TableHeader0).Count - 1))
  151.                        
  152.                         ' create the test header
  153.                        crtTableHeader = Join(a.Transpose(a.Transpose(tempRng.Value)), TableHeaderDelimiter) _
  154.                             & TableHeaderDelimiter
  155.                        
  156.                         ' if found a new header, current row is a table title
  157.                        If crtTableHeader = TableHeaderValue0 Then
  158.                             ' define the new table title range
  159.                            Set RngTitle = Range(Cells(j, Range(TableTitle0).Column), _
  160.                                     Cells(j + TableTitleSize - 1, Range(TableTitle0).Column))
  161.                         End If
  162.                         Range(Cells(j, LastCol + PageTitleSize + 1), _
  163.                             Cells(j, LastCol + PageTitleSize + TableTitleSize - 1)).Value = _
  164.                             a.Transpose(RngTitle.Value)
  165.                     End If
  166.                    
  167.                     '5c) table info
  168.                    If TableInfo0 <> "" Then
  169.                         ' check if the current row contains a new table info by verifying
  170.                        ' if table info is on the expected position
  171.                        Set tempRng = Range(Cells(j + TtTiDistance, Range(TableHeader0).Column), _
  172.                         Cells(j + TtTiDistance, Range(TableHeader0).Column + Range(TableHeader0).Count - 1))
  173.                        
  174.                         ' create the test header
  175.                        crtTableHeader = Join(a.Transpose(a.Transpose(tempRng.Value)), TableHeaderDelimiter) _
  176.                             & TableHeaderDelimiter
  177.                        
  178.                         ' if found a new header, current row is a table info
  179.                        If crtTableHeader = TableHeaderValue0 Then
  180.                             ' define the new table info range
  181.                            Set RngInfo = Cells(j, Range(TableInfo0).Column)
  182.                         End If
  183.                         tempArr = Split(RngInfo.Value, TableInfoDelim0, TableInfoCols)
  184.                         Range(Cells(j, LastCol + PageTitleSize + TableTitleSize), _
  185.                             Cells(j, LastCol + PageTitleSize + TableTitleSize + TableInfoSize - 1)).Value = _
  186.                             tempArr
  187.                     End If
  188.                     ' add file and sheet name
  189.                    Cells(j, LastCol + PageTitleSize + TableTitleSize + TableInfoSize).Value = file.Path
  190.                     Cells(j, LastCol + PageTitleSize + TableTitleSize + TableInfoSize + 1).Value = Sheets(i).Name
  191.                 Next j
  192.                 Set RngTitle = Nothing
  193.                 Set RngInfo = Nothing
  194.                 SheetStatus = "Processed, format ok"
  195.             Else
  196.                 SheetStatus = "Not processed, other format"
  197.             End If
  198.             Cells(1, LastCol + PageTitleSize + TableTitleSize + TableInfoSize).Value = "File"
  199.             Cells(1, LastCol + PageTitleSize + TableTitleSize + TableInfoSize + 1).Value = "Sheet"
  200.            
  201.             ' add summary to array
  202.            arrRow = UBound(arrStatus, 2) + 1
  203.             ReDim Preserve arrStatus(2, arrRow)
  204.             arrStatus(0, arrRow) = file.Path
  205.             arrStatus(1, arrRow) = Sheets(i).Name
  206.             arrStatus(2, arrRow) = SheetStatus
  207.         Next i
  208.         extWkb.Close SaveChanges:=True, Filename:=DestinationPath & "\" & file.Name
  209.     Next
  210.    
  211.     ' write the summary to a sheet
  212.    If SheetExists("Summary") Then Sheets("Summary").Delete
  213.     Sheets.Add , Sheets(Sheets.Count)
  214.     ActiveSheet.Name = "Summary"
  215.     Range(Cells(1, 1), Cells(arrRow + 1, 3)).Value = a.Transpose(arrStatus)
  216.     Range("A1:C1").Value = Split("File Sheet Status")
  217.    
  218.     MsgBox "Done!"
  219.     Call ToggleExcelFunctionalities(True)
  220. End Sub

Add a Comment

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.