Question

我在下面有以下代码，

我想让整行不仅仅是原始数组的第1列，我该怎么做？

Sub Example1()
    Dim arrValues() As Variant
    Dim lastRow As Long
    Dim filteredArray()
    Dim lRow As Long
    Dim lCount As Long
    Dim tempArray()

    lastRow = Sheets("Raw Data").UsedRange.Rows(Sheets("Raw Data").UsedRange.Rows.Count).Row
    arrValues = Sheets("Raw Data").Range(Cells(2, 1), Cells(lastRow, 21)).Value

    ' First use a temporary array with just one dimension
    ReDim tempArray(1 To UBound(arrValues))
    For lCount = 1 To UBound(arrValues)
        If arrValues(lCount, 3) = "phone" Then
            lRow = lRow + 1
            tempArray(lRow) = arrValues(lCount, 1)
        End If
    Next

    ' Now we know how large the filteredArray needs to be: copy the found values into it
    ReDim filteredArray(1 To lRow, 1 To 1)
    For lCount = 1 To lRow
        filteredArray(lCount, 1) = tempArray(lCount)
    Next

    Sheets("L").Range("A2:U" & 1 + lRow) = filteredArray
End Sub

Answer 1

ReDim statement可以使用 PRESERVE 参数即时添加记录，但只能添加到最后一个等级。这是一个问题，因为二维数组的第二级通常被认为是＆＃39;列＆＃39;而第一个是＆＃39;行＆＃39;。

Application.Transpose可以将行翻转成列，反之亦然，但它有局限性。（请参阅here和here）

在没有这些限制的情况下进行转置的简单功能实际上非常容易构建。你真正需要的只是两个数组和两个嵌套循环来翻转它们。

Sub Example1()
    Dim arrVALs() As Variant, arrPHONs() As Variant
    Dim v As Long, w As Long

    With Sheets("Raw Data").Cells(1, 1).CurrentRegion
        With .Resize(.Rows.Count - 1, 21).Offset(1, 0)
            arrVALs = .Cells.Value
            'array dimension check
            'Debug.Print LBound(arrVALs, 1) & ":" & UBound(arrVALs, 1)
            'Debug.Print LBound(arrVALs, 2) & ":" & UBound(arrVALs, 2)
            'Debug.Print Application.CountIf(.Columns(3), "phone") & " phones"
        End With
    End With

    ReDim arrPHONs(1 To UBound(arrVALs, 2), 1 To 1)
    For v = LBound(arrVALs, 1) To UBound(arrVALs, 1)
        If LCase(arrVALs(v, 3)) = "phone" Then
            For w = LBound(arrVALs, 2) To UBound(arrVALs, 2)
                arrPHONs(w, UBound(arrPHONs, 2)) = arrVALs(v, w)
            Next w
            ReDim Preserve arrPHONs(1 To UBound(arrPHONs, 1), _
                                    1 To UBound(arrPHONs, 2) + 1)
        End If
    Next v

    'there is 1 too many in the filtered array
    ReDim Preserve arrPHONs(1 To UBound(arrPHONs, 1), _
                            1 To UBound(arrPHONs, 2) - 1)

    'array dimension check
    'Debug.Print LBound(arrPHONs, 1) & ":" & UBound(arrPHONs, 1)
    'Debug.Print LBound(arrPHONs, 2) & ":" & UBound(arrPHONs, 2)

    'Option 1: use built-in Transpose
    'Worksheets("L").Range("A2:U" & UBound(arrPHONs, 2) + 1) = Application.Transpose(arrPHONs)

    'Option 2: use custom my_2D_Transpose
    Worksheets("L").Range("A2:U" & UBound(arrPHONs, 2) + 1) = my_2D_Transpose(arrPHONs)

End Sub

Function my_2D_Transpose(arr As Variant)
    Dim a As Long, b As Long, tmp() As Variant
    ReDim tmp(1 To UBound(arr, 2), 1 To UBound(arr, 1))
    For a = LBound(arr, 1) To UBound(arr, 1)
        For b = LBound(arr, 2) To UBound(arr, 2)
            tmp(b, a) = Trim(arr(a, b))
        Next b
    Next a
    my_2D_Transpose = tmp
End Function

因此，如果您赶时间并且数组的范围使您永远不会达到Application.Transpose的限制，那么一定要使用它。如果您无法安全地使用转置，请使用自定义功能。

得到整行的数组

1 个答案: