我正在使用 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 列都填充了第一列的資料。
您的建議將不勝感激。
uj5u.com熱心網友回復：
此代碼會將您從表中指定的任何列復制到新作業簿中的相鄰列。
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
uj5u.com熱心網友回復：
獲取多列范圍
在您的情況下，您會執行以下操作：
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
轉載請註明出處，本文鏈接：https://www.uj5u.com/houduan/390703.html