How to create a multidimensional array from non-adjacent table columns

This code will copy whichever columns you specify from the table to adjacent columns in the new workbook.

Option Explicit

Sub TblToTxtFile()
'PURPOSE:   Create a txt file from the Excel table

Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xNum As Long
Dim rngArea As Range
Dim rngCol As Range
Dim rngDst As Range
Dim rngSrc As Range
Dim xWBNew As Workbook
Dim xFileName As String: xFileName = xWB.Path & "\" & Left(xWB.Name, 6) & " Import.txt"

    With xWB.Sheets("Entries").ListObjects("Entries_Report")
        xNum = .DataBodyRange.Rows.Count
        Set rngSrc = Union(.ListColumns("Field1").DataBodyRange, .ListColumns("Field3").DataBodyRange, .ListColumns("Field4").DataBodyRange)
    End With

    Set xWBNew = Workbooks.Add

    Set rngDst = xWBNew.ActiveSheet.Range("A1:A" & xNum)

    For Each rngArea In rngSrc.Areas
        For Each rngCol In rngArea.Columns
            Debug.Print rngCol.Address
            With rngDst
                .NumberFormat = "0"    'Keeps account number from being converted to scientific numbers
                .Value = rngCol.Value
            End With

            Set rngDst = rngDst.Offset(, 1)
        Next rngCol
    Next rngArea

    With xWBNew
        .SaveAs Filename:=xFileName, FileFormat:=xlText, CreateBackup:=False
        .Close savechanges:=False
    End With

End Sub

Get Multi-Column Range

• In your case you would do something like:

  xArray = GetMultiColumnRange(.Union(...))
  

• If you'll have more or fewer columns, make your code dynamic. See the example at the bottom.

The Functions

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a multi-range in a 2D one-based array.
'               The values of the areas are written next to each other.
' Remarks:      Before constructing the resulting array, the maximum number
'               of rows and the total number of columns is determined.
' Calls:        'GetRange'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetMultiColumnRange( _
    mcrg As Range) _
As Variant
    Const ProcName As String = "GetMultiColumnRange"
    On Error GoTo ClearError
    
    Dim aCount As Long: aCount = mcrg.Areas.Count
    If aCount = 1 Then
        GetMultiColumnRange = GetRange(mcrg)
        Exit Function
    End If
    
    Dim aData As Variant: ReDim aData(1 To aCount, 1 To 3)
    Dim arg As Range
    Dim rCount As Long
    Dim cCount As Long
    Dim arCount As Long
    Dim acCount As Long
    Dim a As Long
    
    For Each arg In mcrg.Areas
        a = a + 1
        ' 1st Column
        arCount = arg.Rows.Count
        aData(a, 1) = arCount ' area rows count
        If rCount < arCount Then ' max rows
            rCount = arCount
        End If
        ' 2nd Column
        acCount = arg.Columns.Count
        aData(a, 2) = acCount ' area columns count
        cCount = cCount + acCount ' total columns
        ' 3rd Column
        aData(a, 3) = GetRange(arg) ' 2D One-Based Area Array
    Next arg
    
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
    
    Dim r As Long
    Dim ac As Long
    Dim lc As Long
    Dim dc As Long
    
    For a = 1 To aCount
        For r = 1 To aData(a, 1)
            dc = lc
            For ac = 1 To aData(a, 2)
                dc = dc + 1
                dData(r, dc) = aData(a, 3)(r, ac)
            Next ac
        Next r
        lc = dc
    Next a
    
    GetMultiColumnRange = dData

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "    " & Err.Description
    Resume ProcExit
End Function

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the values of a range ('rg') in a 2D one-based array.
' Remarks:      If ˙rg` refers to a multi-range, only its first area
'               is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
    ByVal rg As Range) _
As Variant
    If rg Is Nothing Then Exit Function
    
    If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
        Dim data As Variant: ReDim data(1 To 1, 1 To 1): data(1, 1) = rg.Value
        GetRange = data
    Else ' multiple cells
        GetRange = rg.Value
    End If

End Function

An Example

Sub GetMultiColumnRangeTEST()
    
    Dim smrg As Range: Set smrg = Sheet1.Range("A1:A5000,C1:D30,F1:F10000")
    
    Dim Data As Variant: Data = GetMultiColumnRange(smrg)
    If IsEmpty(Data) Then Exit Sub
    
    Dim rCount As Long: rCount = UBound(Data, 1)
    
    Dim dfCell As Range: Set dfCell = Sheet1.Range("H1")
    Dim drg As Range: Set drg = dfCell.Resize(rCount, UBound(Data, 2))
    drg.Value = Data
    drg.Resize(Sheet1.Rows.Count - drg.Row - rCount + 1).Offset(rCount).Clear

End Sub