將 VBA 二維數組的給定列復制到工作表列

Question

我正在從制表符分隔的文本文件中導入表格。 我只對某些列感興趣，所以這就是我想要做的：

沒問題：將整個文件讀入一個長字符串

沒問題：沿 vbCrlf 將長字符串拆分為行

沒問題：沿 vbTab 將每一行拆分為單元格。 將這些值放入二維數組

問題： Sheets("Sheet2").Range("A:A") = Matrix （僅選定的列）

我需要幫助來找到如何解決例如矩陣的第 5 列，所有行的語法。

我說清楚了嗎？

Open Filename For Binary As #1

MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
strData() = Split(MyData, vbCrLf)
Debug.Print strData(1)

Dim Matrix() As String
Dim Fields() As String
Fields = Split(strData(0), vbTab)
Dim Rader As Long
Dim Kolumner As Long
ReDim Matrix(UBound(strData), UBound(Fields))
For Rader = 0 To UBound(strData)
    Fields() = Split(strData(Rader), vbTab)
    For Kolumner = 0 To UBound(Fields)
        Matrix(Rader, Kolumner) = Fields(Kolumner)
    Next Kolumner
Next Rader
Sheets("Sheet2").Range("A:A") = Matrix 'that gets me the first column. How to pick another matrix column?

Answer 1

僅將數組中的指定列寫入工作表

• 調整包括工作簿和DataColumns在內的常量。
• 第first Sub將DataColumns中指定的列寫入工作表。
• second Sub將所有列寫入工作表。
• 正在調用 rest。
• ByRef （非必需）用於指出引用變量中的值正在被修改。

編碼

Option Explicit

Sub writeColumns()
    
    ' Text
    Const FilePath As String = "G:\Data\Baby Names\yob2018.txt"
    Const LineDelimiter As String = vbCrLf
    Const FieldDelimiter As String = ","
    
    ' Worksheet
    Const wsId As Variant = "Sheet1"
    Const FirstCell As String = "A1"
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim DataColumns() As Variant: DataColumns = Array(3, 1)
    
    ' Write from Text File to Data Array.
    Dim Data() As String
    getTextToArray Data, FilePath, LineDelimiter, FieldDelimiter
 
    ' Write from Data Array to Columns Array.
    Dim Cols() As Variant: Cols = getColumns(Data, DataColumns)
    
    ' Write from Columns Array to Columns Range.
    writeWorksheet Cols, wb, wsId, FirstCell

End Sub

Sub writeAll()
    
    ' Text
    Const FilePath As String = "G:\Data\Baby Names\yob2018.txt"
    Const LineDelimiter As String = vbCrLf
    Const FieldDelimiter As String = ","
    
    ' Worksheet
    Const wsId As Variant = "Sheet1"
    Const FirstCell As String = "A1"
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Write from Text File to Data Array.
    Dim Data() As String
    getTextToArray Data, FilePath, LineDelimiter, FieldDelimiter

    ' Write from Data Array to Data Range.
    writeWorksheet Data, wb, wsId, FirstCell

End Sub

Sub getTextToArray(ByRef Data() As String, _
                   ByVal FilePath As String, _
                   Optional ByVal LineDelimiter As String = vbCrLf, _
                   Optional ByVal FieldDelimiter As String = " ")
    
    ' Write from Text File to Text Variable.
    Dim Text As String: getText Text, FilePath
    
    ' Write from Text Variable to Lines Array.
    Dim Lines() As String: getLines Lines, Text, LineDelimiter
    
    ' Split Lines Array to Data Array.
    getFields Data, Lines, FieldDelimiter

End Sub

Sub getText(ByRef Text As String, _
            ByVal TextFilePath As String)
    Open TextFilePath For Binary As #1
    Text = Space$(LOF(1)): Get #1, , Text
    Close #1
End Sub

Sub getLines(ByRef Lines() As String, _
             ByVal Text As String, _
             Optional ByVal LineDelimiter As String = vbCrLf)
    Lines = Split(Text, LineDelimiter)
    removeLastEmptyLines Lines
End Sub

Sub removeLastEmptyLines(ByRef Lines() As String)
    If UBound(Lines) = -1 Then Exit Sub
    Dim c As Long, ub As Long: ub = UBound(Lines)
    For c = ub To LBound(Lines) Step -1
        If Lines(c) = Empty Then
            ub = ub - 1: ReDim Preserve Lines(ub)
        Else
            Exit For
        End If
    Next c
End Sub

Sub getFields(ByRef Data() As String, _
              Lines() As String, _
              Optional ByVal FieldDelimiter As String = " ")
    Dim Fields() As String: Fields = Split(Lines(0), FieldDelimiter)
    Dim ubL As Long: ubL = UBound(Lines) + 1
    Dim ubF As Long: ubF = UBound(Fields) + 1
    ReDim Data(1 To ubL, 1 To ubF)
    Dim r As Long, c As Long
    For r = 1 To ubL
        Fields = Split(Lines(r - 1), FieldDelimiter)
        For c = 1 To ubF
            Data(r, c) = Fields(c - 1)
        Next c
    Next r
End Sub

Function getColumns(Data() As String, _
                    DataColumns() As Variant) _
         As Variant
    Dim ubD As Long: ubD = UBound(Data)
    Dim ubC As Long: ubC = UBound(DataColumns)
    Dim Result As Variant: ReDim Result(1 To UBound(Data), 1 To ubC + 1)
    Dim r As Long, c As Long
    For r = 1 To ubD
        For c = 0 To ubC
            Result(r, c + 1) = Data(r, DataColumns(c))
        Next c
    Next r
    getColumns = Result
End Function

Sub writeWorksheet(Data As Variant, WorkbookObject As Workbook, _
                   Optional ByVal WorksheetNameOrIndex As Variant = "Sheet1", _
                   Optional ByVal FirstCellAddress As String = "A1")
    With WorkbookObject.Worksheets(WorksheetNameOrIndex).Range(FirstCellAddress)
        .Resize(UBound(Data), UBound(Data, 2)).Value = Data
    End With
End Sub