get entire row of array

问题:

I have the following code below,

I want to get the entire row not just column 1 of the original array, how would i do this?

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

回答1:

The ReDim statement can add records on-the-fly with the PRESERVE parameter but only into the last rank. This is a problem as the second rank of a two dimensioned array is typically considered the 'columns' while the first are the 'rows'.

The Application.Transpose can flip rows into columns and vise-versa but it has limitations. (see here and here)

A simple function to transpose without these limitations is actually very easy to build. All you really need are two arrays and two nested loops to flip them.

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

So if you are in a hurry and the scope of your arrays is such that you will never reach the limits of Application.Transpose then by all means use it. If you cannot safely use transpose then use a custom function.