Excel VBA从不相邻的表列创建多维数组

Question

我正在使用 Excel 中的表格，并希望将来自 3 个不相邻表格列的数据放入一个数组中。然后将该数组写入新工作簿的空白工作表中的 3 列 (A:C)，并将其保存为文本文件。

当我的表格列彼此相邻并按照我需要的顺序排列时，以下代码可以完美运行（使用辅助列实现）。

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

不幸的是，在最终的项目中，重新排列或向表中添加辅助列是不可行的，因此我需要一个不需要更改原始表的解决方案。

当我尝试指示代码将数据从未更改的表（原始列的原始顺序）中提取到数组中时，结果是数组中的所有 3 列都填充了第一列中的数据。

您的建议将不胜感激。

Answer 1

获取多列范围

• 在你的情况下，你会做这样的事情：

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

• 如果您有更多或更少的列，请让您的代码动态化。请参阅底部的示例。

函数

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 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

一个例子

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

Answer 2

此代码会将您指定的任何列从表中复制到新工作簿中的相邻列。

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