How to skip a column in array VBA

Question

I have a source workbook and destination workbook and want to map all data from source wb to destination wb but the columns go in a specific order based on a mappings. Both source and destination header can be any length but the importance one will be the destination header because I don’t want to bring back all data just want data that i need based on mapping.

I got stuck on the loops where I need to offset the columns because when I am writing to the destination wb it will write column after column which is not what I intended. So if there is blank in the mapping then leaves that column as empty and move to next one and when writing this to the workbook the array should have same number of columns but the data in the right place. Any help will be greatly appreciated as I’ve tried various ways but always end up with wrong data or not working at all. The below works but when writing the data it dose without skipping whatever is not in the mapping so then I need to manually change the columns to fit the right data in the right column might as well do copy and paste but I thought array will be a lot faster at this task as the data is large in rows over 300k rows.

The picture is put together from different sheets and will not have the yellow row this is to make it clear what data belongs to what. The data mapping the first row will have the worksheet name where I will write the data.

Option Explicit
Sub DataTransformation()
    Dim wsDataMapping As Worksheet
    Dim targetWS As Worksheet
    Dim sourceWB As Workbook
    Dim targetWB As Workbook
    Dim destMapping As Range
    Dim destMappingCell As Range
    Dim srcData As Range
    Dim destData as Range
    Dim srcArr As Variant
    Dim destArr() As Variant
    Dim LCol As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim sourceLRow As Long
    Dim targetLRow As Long
    Dim remainingFiles As String
    Dim time As Variant
   
    time = Now()
    Application.ScreenUpdating = False
   
    Set targetWB = ActiveWorkbook
    With targetWB
        Set wsDataMapping = .Sheets("Data Mapping")
        Set targetWS = .Sheets(wsDataMapping.Range("A1").value)
    End With
   
    LCol = targetWS.Cells(16, targetWS.Columns.Count).End(xlToLeft).Column
   
    Set destMapping = wsDataMapping.Range("A2:A" & wsDataMapping.Range("A" & wsDataMapping.Rows.Count).End(xlUp).Row)
   
    Dim filePath As String
    Dim fileName As Variant
    Dim allFiles As Collection
    Set allFiles = New Collection
    filePath = "C:\Users\" & Environ(“UserName”) & "\Desktop\Test M" & "\"
    'fileName = Dir(filePath & "*.*")
    Set allFiles = LoopThroughFiles(filePath, ".*")
   
For Each fileName In allFiles
 
    Set sourceWB = Workbooks.Open(filePath & fileName)
    Set srcData = sourceWB.Worksheets(1).Range("A1").CurrentRegion
    Set destData = targetWS.Range(targetWS.Cells(13, 3), targetWS.Cells(13, LCol))
   
    sourceLRow = sourceWB.Worksheets(1).Range("A" & sourceWB.Worksheets(1).Rows.Count).End(xlUp).Row
    targetLRow = FindLastRow(targetWS, 3, LCol)
   
    If (targetWS.Rows.Count - targetLRow) > sourceLRow Then
        srcArr = srcData.value
 
        ReDim Preserve destArr(1 To UBound(srcArr, 1), 1 To UBound(srcArr, 2))
 
        For Each destMappingCell In destMapping
            x = 0
            For i = LBound(srcArr, 2) To UBound(srcArr, 2)
             
                If destMappingCell.Offset(0, 1).value = srcArr(1, i) Then
                    x = x + 1
                    For j = LBound(srcArr, 1) To UBound(srcArr, 1)
                        'Debug.Print srcArr(j, i)
                        destArr(j, x) = srcArr(j, i)
                    Next j
                End If
            Next i
        Next destMappingCell
       
        sourceWB.Close False
        targetWS.Range("C" & targetLRow).Resize(UBound(destArr, 1), UBound(destArr, 2)).value = destArr
    Else
        sourceWB.Close False
        remainingFiles = remainingFiles & " " & fileName & vbNewLine
    End If
Next fileName
 
Application.ScreenUpdating = True
MsgBox time & " after run " & Now() & vbNewLine & "Files remaining to process are " & vbNewLine & remainingFiles
End Sub
Function LoopThroughFiles(inputDirectoryToScanForFile, filenameCriteria) As Collection
 
    Dim strFile As String
    Dim fileNames As Collection
 
    Set fileNames = New Collection
 
    strFile = Dir(inputDirectoryToScanForFile & "\*" & filenameCriteria)
    Do While Len(strFile) > 0
        'Debug.Print strFile
        fileNames.Add (strFile)
        strFile = Dir 'returns a new file
    Loop
    Set LoopThroughFiles = fileNames
End Function
Function FindLastRow(ByVal ws As Worksheet, Optional ByVal FromCol As Long = 0, Optional ByVal ToCol As Long = 0) As Long
Dim i As Long
Dim lastRow As Long
If FromCol = 0 Then FromCol = 3
If ToCol = 0 Then ToCol = 10
For i = FromCol To ToCol
    lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
    If FindLastRow < lastRow Then
        FindLastRow = lastRow
    End If
Next i
If FindLastRow < 17 Then FindLastRow = 17
End Function

Tony Dallimore · Accepted Answer

Solution

The code below works against my test workbooks. I believe I have handled your offsets correctly. Lines starting '### require amendment for your system. I believe the remainder of the macros will work without change. Copy this code to a new module, adjust as required and try it out. The comments within the code should explain everything. If the comments are not adequate, ask questions and I will update the comments.

Option Explicit

  ' * I have a naming system for my constants and variables that I have used for years.
  '   Having a system means I can look at code I wrote years ago and recognise the
  '   constants and variables.  If you do not like my system, design your own but do
  '   code without a system if you wih to easily maintain old code.
  ' * Col, Inx, Row, Wsht and Wbk identify the name as relating to a column, index,
  '   row, worksheet or workbook.
  ' * Col, Row, Wsht and Wbk are followed by Xxx which is a code or abbreviation
  '   identifying the worksheet or workbook.
  ' * Values for Xxx in these macros are:
  '      Map  for the Data mapping table.
  '      Src  for a source workbook or worksheet
  '      Dest for the destination worksheet
  '      This for the workbook holding the macros and the destination worksheet.
  ' * Next, Crnt, Last destinguish different columns or rows if necessary.
  ' * InxX is an index for a 1D array or collection. Since the use is ArrayName(InxX),
  '   X is usually a single letter.
  ' * ColXxxDataFirst and RowXxxDataFirst define the first data column and row
  '   within worksheet Xxx.  This allows the number of header columns or rows to be
  '   changed with minimum effect on the code.
  ' * Fldr identifie a folder.  If the code accesses both Outlook and disc folders,
  '   the prefixes OutFldr and DscFldr are used instead.
  ' If the purpose of a variable does not fit within the above system, I use the
  ' name of the purpose for the variable.  For example DataMap.

  ' These constants identify which worksheet within this workbook holds the
  ' mapping table and its position within that worksheet.
  ' Cells(RowMapDataFirst, ColMapDataFirst) is the top left cell of the table
  ' excluding any column headings.
  ' Cells(RowMapDataFirst, ColMapDataFirst+1)
  ' ### Adjust as required.
  Const ColMapDataFirst As Long = 1
  Const RowMapDataFirst As Long = 2
  Const WshtDataName As String = "Data Mapping"

  ' Columns to the left of ColDestDataFirst and above RowDestDataFirst-1 are reserved.
  ' The data mapping table specifies the first destination column as 1. ColDestDataFirst
  ' specifies the true first destination column. When moving source columns to the
  ' destination worksheet, the destination column is adjusted for ColDestDataFirst.
  ' If at the start of this routine, the last row in the destination worksheet is less
  ' than RowDestDataFirst-1, the column headings will be written to RowDestDataFirst-1 and
  ' the first data will be written to RowDestDataFirst. If at the start of this routine,
  ' the last row in the destination worksheet is not less than RowDestDataFirst-1, the
  ' column headings will not be written to RowDestDataFirst-1 and the first data will be
  ' written to RowDestLast+1
  ' ### Adjust as required.
  Const ColDestDataFirst As Long = 3
  Const RowDestDataFirst As Long = 18
  Const WshtDestName As String = "Destination"

  ' First data row of a source worksheet.
  ' Note this code does not allow for source worksheets having different
  ' numbers of heding rows.
  Const RowSrcDataFirst As Long = 2

Sub CollectAndTransform()

  ' Collects data from all the source workbooks in the source folder and saves
  ' that data to the destination worksheet within this workbook.

  ' The Source folder is defined by FldrSrc.
  ' A source workbook is any workbook within FldrSrc that contains a worksheet which
  ' has all the required source columns.
  ' The data is saved by column with the new column sequence defined by the Data mapping
  ' table.
  ' The position of the Data mapping table is defined by ColDataDataFirst,
  ' RowDataDataFirst and WshtDataName.  See below where the data map is loaded to
  ' DataMap for more information. The format of the data map is defined at the top of
  ' sub DecodeMapping().

  ' 20Apr20  Coded.

  Dim ColDestCrnt As Long
  Dim ColDestLast As Long
  Dim ColsDestName() As String
  Dim ColSrcLast As Long
  Dim ColsSrcForDest() As Long
  Dim DataMap As Variant
  Dim Filename As String
  Dim FldrSrc As String
  Dim RngSrc As Range
  Dim RowDestLast As Long
  Dim RowMapLast As Long
  Dim RowSrcLast As Long
  Dim WbkSrc As Workbook
  Dim WbkThis As Workbook
  Dim WshtDest As Worksheet
  Dim WshtMap As Worksheet
  Dim WshtSrc As Worksheet

  Application.ScreenUpdating = False

  Set WbkThis = ThisWorkbook

  ' ### Replace by FldrSrc = "C:\Users\" & Environ(“UserName”) & "\Desktop\Test M" & "\"
  FldrSrc = ThisWorkbook.Path & "\"

  Set WshtMap = WbkThis.Worksheets("Data Mapping")
  Set WshtDest = WbkThis.Worksheets(WshtDestName)

  With WshtMap
    RowMapLast = .Cells(Rows.Count, 1).End(xlUp).Row
    DataMap = .Range(.Cells(RowMapDataFirst, 1), .Cells(RowMapLast, 2)).Value
    ' Note 1: the lower bounds of a variant loaded from a range are always one
    '         regardless of the location of the range within the worksheet.
    ' Note 2: I have loaded DataMap starting at row 2 because RowMapDataFirst
    '         equals 2.  If you want the table to start at a different row, just
    '         change the value of RowMapDataFirst.
  End With

  Filename = Dir$(FldrSrc & "*.xls*")
  Do While Filename <> "" And Filename <> ThisWorkbook.Name
    Set WbkSrc = Workbooks.Open(FldrSrc & Filename, , True)
    Set WshtSrc = FindSrcWsht(WbkSrc, DataMap)
    If WshtSrc Is Nothing Then
      Debug.Print WbkSrc.Name & " is is not a source workbook"
    Else
      ' This workkbook is a source workbook
      ' Call DecodeMapping here in case column sequence differs between workbooks.
      Call DecodeMapping(WshtSrc, DataMap, ColsDestName, ColsSrcForDest)
      If RowDestLast < RowDestDataFirst - 1 Then
        ' This is the first source workbook so the destination worksheet
        ' has not been checked
        Call FindLastRowCol(WshtDest, RowDestLast, ColDestLast)
        If RowDestLast < RowDestDataFirst - 1 Then
          ' No data has been written to the destination worksheet
          ' Output column headings
          With WshtDest
            .Range(.Cells(RowDestDataFirst - 1, ColDestDataFirst), _
                   .Cells(RowDestDataFirst - 1, ColDestDataFirst + _
                                                UBound(ColsDestName) - 1)).Value = ColsDestName
          End With
          RowDestLast = RowDestDataFirst - 1
        End If
      End If
      Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
      ' For each destination column which is not to be left empty,
      ' copy the appropriate source column to it.
      ' If ColDestCrnt(N) <> 0, source column ColDestCrnt(N) is to be copied
      ' to destination column N + ColDestDatFirst - 1
      ' A source column is from RowSrcDataFirst to RowSrcLast
      For ColDestCrnt = 1 To UBound(ColsSrcForDest)
        If ColsSrcForDest(ColDestCrnt) <> 0 Then
          With WshtSrc
            Set RngSrc = .Range(.Cells(RowSrcDataFirst, ColsSrcForDest(ColDestCrnt)), _
                                .Cells(RowSrcLast, ColsSrcForDest(ColDestCrnt)))
          End With
          Debug.Print WbkSrc.Name & "." & WshtSrc.Name & "Range("; RngSrc.Address & " ) -> " & _
                      WshtDest.Cells(RowDestLast + 1, ColDestCrnt + ColDestDataFirst - 1).Address
          RngSrc.Copy WshtDest.Cells(RowDestLast + 1, ColDestCrnt + ColDestDataFirst - 1)
        End If
      Next
      RowDestLast = RowDestLast + RngSrc.Rows.Count   ' Advance to bottom of data just copied
                                                      ' ready for next source workbook
    End If
    WbkSrc.Close
    Filename = Dir$
  Loop

  WshtDest.Columns.AutoFit

  Application.ScreenUpdating = True

End Sub
Sub DecodeMapping(ByRef WshtSrc As Worksheet, ByRef DataMap As Variant, _
                  ByRef ColsDestName() As String, ByRef ColsSrcForDest() As Long)

  ' Decodes a table mapping source column names to destination column names.

  ' Create an array of column headings for the destination worksheet.
  ' Locates the source column names within the source worksheet and creates an
  ' array mapping the source column numbers to the destination columns.

  ' WshtSrc        The source worksheet
  ' DataMap        A Variant holding a 2D table with 2 columns and 1 row per
  '                destination column.  Table column 1 contains the names of the
  '                destination columns in output sequence with table row N
  '                holding the name of destination column N.  Table column 2 of
  '                row N contains the name of the source column, if any, for the
  '                destination column whose name is in table column 1 or row N.
  ' ColsDestNames  On exit, the names of the destination columns in an array
  '                ready to be loaded to the header row of the destination
  '                worksheet.
  ' ColsSrcForDest On exit, ReDimmed to (1 To M) where M is the number of columns
  '                in the destination worksheet.  If ColsSrcForDest(P) = 0,
  '                destination column P is left blank.  If ColsSrcForDest(P) = Q,
  '                source column Q is to be copied to destination column P.

  ' 18Apr20  Coded.

  Dim ColSrcCrnt As Long
  Dim ColSrcLast As Long
  Dim Found As Boolean
  Dim RowMapCrnt As Long
  Dim RowSrcLast As Long

  ReDim ColsDestName(1 To UBound(DataMap, 1))

  ' Build array that can be used to create heading row for destination worksheet
  For RowMapCrnt = 1 To UBound(DataMap, 1)
    ColsDestName(RowMapCrnt) = DataMap(RowMapCrnt, 1)
  Next

  Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)  ' Only need ColSrcLast

  ' Size ColsSrcForDest so there is one entry per destination column
  ' The entries are initialised to zeros.
  ReDim ColsSrcForDest(1 To UBound(DataMap))

  ' There are faster methods of achieving the source to destination mapping
  ' than these nested loops but the VBA is more complicated.  If there are
  ' so many source and destination columns that this is slow, I will recode.
  ' Match each value in column 2 of DataMap against a column heading in
  ' worksheet WshtSrc.  When a match is found, record the match in ColsSrcForDest.
  With WshtSrc
    For RowMapCrnt = 1 To UBound(DataMap)
      If DataMap(RowMapCrnt, 2) <> "" Then
        'Debug.Assert False
        Found = False
        For ColSrcCrnt = 1 To ColSrcLast
          If .Cells(1, ColSrcCrnt).Value = DataMap(RowMapCrnt, 2) Then
            ' Warning: this a case sensitive match
            'Debug.Assert False
            ColsSrcForDest(RowMapCrnt) = ColSrcCrnt
            Found = True
            Exit For
          End If
        Next
        If Not Found Then
          Debug.Assert False
          Call MsgBox("Source column name """ & DataMap(RowMapCrnt, 2) & _
                      """ appears in the DataMap but is not a column " & _
                      "heading in worksheet """ & WshtSrc.Name & """", vbOKOnly)
          End     ' Exit this macro and calling macro.
        End If
      End If
    Next
  End With

End Sub
Function FindSrcWsht(ByRef WbkSrc As Workbook, ByRef DataMap As Variant) As Worksheet

  ' Return a reference to the worksheet within WbkSrc that has all the columns
  ' required by DataMap for a source worksheet.  Return Nothing if no such
  ' worksheet found.

  ' WbkSrc         A workbook that might be a source workbook
  ' DataMap        A Variant holding a 2D table with 2 columns and 1 row per
  '                destination column.  Table column 1 contains the names of the
  '                destination columns in output sequence with table row N
  '                holding the name of destination column N.  Table column 2 of
  '                row N contains the name of the source column, if any, for the
  '                destination column whose name is in table column 1 or row N.

  ' Column 1 of DataMap is not used by this routine.
  ' Column 2 of DataMap contains column names that must exist within a source
  ' worksheet.
  ' Workbook WbkSrc can contain one or more worksheets. Match the column names
  ' within each worksheet against the column names in column 2 of DataMap until
  ' a worksheet is found with all required columns.  Retun a reference to that
  ' worksheet.  Return Nothing if no satisfactory worksheet is found.

  ' 19Apr20  Coded

  Dim ColSrcCrnt As Long
  Dim ColSrcLast As Long
  Dim InxNR As Long
  Dim InxWsht As Long
  Dim MatchAll As Boolean
  Dim MatchSingleFound As Boolean
  Dim NamesRequired As Collection
  Dim RowMapCrnt As Long
  Dim RowSrcLast As Long

  Set NamesRequired = New Collection

  ' Create collection of the column names required in a worksheet
  For RowMapCrnt = 1 To UBound(DataMap, 1)
    If DataMap(RowMapCrnt, 2) <> "" Then
      NamesRequired.Add DataMap(RowMapCrnt, 2)
    End If
  Next

  With WbkSrc
    'Debug.Print .Name             ' Name of workbook
    ' For each worksheet, attempt match on every required name
    For InxWsht = 1 To .Worksheets.Count
      With .Worksheets(InxWsht)
        'Debug.Print "  " & .Name    ' Name of worksheet
        Call FindLastRowCol(WbkSrc.Worksheets(InxWsht), RowSrcLast, ColSrcLast)
        MatchAll = True   ' Assume all names matched until name not found
        For InxNR = 1 To NamesRequired.Count
          MatchSingleFound = False    ' Have not yet matched NamesRequired(InxNR)
          For ColSrcCrnt = 1 To ColSrcLast
            If .Cells(1, ColSrcCrnt).Value = NamesRequired(InxNR) Then
              ' Have a case sensitive match between required name and column heading
              'Debug.Assert False
              MatchSingleFound = True
              Exit For
            End If
          Next
          If Not MatchSingleFound Then
            ' NamesRequired(InxNR) not matched against any column heading
            'Debug.Assert False
            'Debug.Print "    Required name """ & NamesRequired(InxNR) & """ not found"
            MatchAll = False
          End If
        Next
        If MatchAll Then
          ' Every required name matched against this worksheet
          Set FindSrcWsht = WbkSrc.Worksheets(InxWsht)
          Exit Function
        End If
      End With
    Next
  End With

  ' If get here, none of the worksheets contains every required name
  Set FindSrcWsht = Nothing

End Function

How to skip a column in array VBA

Answers (2)

Related Questions