[英]Excel VBA to create a multidimensional array from non-adjacent table columns
我正在使用 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 列都填充了第一列中的数据。
您的建议将不胜感激。
此代码会将您指定的任何列从表中复制到新工作簿中的相邻列。
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
在您的情况下,您会执行以下操作:
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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.