I am working with a Table in Excel, and would like to place data from 3 non-adjacent Table columns into an array. The array is then written to 3 columns (A:C) in a blank worksheet in a new workbook, which is saved as a text file.
The following code works perfectly when my table columns are adjacent to each other and arranged in the order I need them (achieved using helper columns).
Sub TblToTxtFile()
'PURPOSE: Create a txt file from the Excel table
Dim xWB As Workbook: Set xWB = ActiveWorkbook
Dim xNum As Long
Dim xArray As Variant
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
xArray = Union(.ListColumns("Account Number").DataBodyRange, .ListColumns("Amount2").DataBodyRange, .ListColumns("Item Description2").DataBodyRange).Value '2 in the column name indicates a helper column
End With
Set xWBNew = Workbooks.Add
With xWBNew.ActiveSheet
.Range("A1:A" & xNum).NumberFormat = "0" 'Keeps account number from being converted to scientific numbers
.Range("A1:C" & xNum) = xArray
End With
With xWBNew
.SaveAs FileName:=xFileName, FileFormat:=xlText, CreateBackup:=False
.Close savechanges:=False
End With
End Sub
Unfortunately, in the final project re-arranging or adding helper columns to the table won't be an option, so I need a solution that doesn't require changes to the original table.
When I try to direct the code to pull data from the unaltered table (the original columns in their original order) into the array, the result is that all 3 columns in the array are populated with data from the first column.
Your suggestions would be much appreciated.
CodePudding user response：
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
CodePudding user response：
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