arrays - 将多个不相邻列复制到数组

Question

我正在尝试将多个不相邻(不连续)的 Excel 列复制到数组中，但它不起作用。以下是我尝试过的...

    Public Function Test()    
        Dim sh As Worksheet: Set sh = Application.Sheets("MyWorksheet")
        Dim lr As Long: lr = sh.Cells(sh.Rows.Count, 1).End(xlUp).row
        Dim r1 As Range: Set r1 = sh.Range("A1:A" & lr)
        Dim r2 As Range: Set r2 = sh.Range("C1:C" & lr)
        Dim rAll As Range: Set rAll = Union(r1, r2)
        'Dim arr() As Variant: arr = Application.Transpose(rAll) <-- Throws Type mismatch error
        'Dim arr As Variant: arr = Application.Transpose(rAll) <-- arr Value = Error 2015
        Dim arr() As Variant: arr = rAll.Value2 ' <-- Only the first column (col A) is loaded.
    End Function

非常感谢任何帮助!

Answer 1

由于像 arr = rAll.Value2 这样将多个值读入数组只能在连续范围内，因此您必须采用替代方案:

替代方案 1:

编写一个函数，以区域方式读取范围值并将其合并到一个数组中。

Option Explicit 

Public Function NonContinousColumnsToArray(ByVal NonContinousRange As Range) As Variant
    Dim iArea As Long
    For iArea = 1 To NonContinousRange.Areas.Count - 1
        If NonContinousRange.Areas.Item(iArea).Rows.CountLarge <> NonContinousRange.Areas.Item(iArea + 1).Rows.CountLarge Then
            MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
            Exit Function
        End If
    Next iArea

    Dim ArrOutput() As Variant
    ArrOutput = NonContinousRange.Value2 'read first area into array

    'read all other areas
    For iArea = 2 To NonContinousRange.Areas.Count
        ReDim Preserve ArrOutput(1 To UBound(ArrOutput, 1), 1 To UBound(ArrOutput, 2) + NonContinousRange.Areas.Item(iArea).Columns.CountLarge) As Variant  'resize array

        Dim ArrTemp() As Variant  'read arrea at once into temp array
        ArrTemp = NonContinousRange.Areas.Item(iArea).Value2

        'merge temp array into output array
        Dim iCol As Long
        For iCol = 1 To UBound(ArrTemp, 2)
            Dim iRow As Long
            For iRow = 1 To UBound(ArrTemp, 1)
                ArrOutput(iRow, UBound(ArrOutput, 2) - UBound(ArrTemp, 2) + iCol) = ArrTemp(iRow, iCol)
            Next iRow
        Next iCol
    Next iArea

    NonContinousColumnsToArray = ArrOutput
End Function

下面的示例程序

Public Sub ExampleTest()
    Dim InputRng As Range
    Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))

    Dim OutputArr() As Variant
    OutputArr = NonContinousColumnsToArray(InputRng)

    Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub

将采用以下非连续范围Union(Range("A1:A9"), Range("C1:D9"))作为输入，

^{图像 1:输入范围为不连续的 A1:A9 和 C1:D9。}

将其合并为一个数组OutputArr并按如下方式写入值

^{图 2:合并的输出数组写回到单元格中。}

---

替代方案 2:使用临时工作表...

…将值粘贴为连续范围，然后可以立即将其读入数组。

Public Sub ExampleTestTempSheet()
    Dim InputRng As Range
    Set InputRng = Union(Range("A1:A9"), Range("C1:D9"))

    Dim OutputArr() As Variant
    OutputArr = NonContinousColumnsToArrayViaTempSheet(InputRng)

    Range("A12").Resize(UBound(OutputArr, 1), UBound(OutputArr, 2)).Value = OutputArr
End Sub

Public Function NonContinousColumnsToArrayViaTempSheet(ByVal NonContinousRange As Range) As Variant
    On Error Resume Next
    NonContinousRange.Copy
    If Err.Number <> 0 Then
        MsgBox "Different amount of rows is not allowed.", vbCritical, "NonContinousColumnsToArray"
        Exit Function
    End If
    On Error GoTo 0

    Dim TempSheet As Worksheet
    Set TempSheet = ThisWorkbook.Worksheets.Add
    TempSheet.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False

    NonContinousColumnsToArrayViaTempSheet = TempSheet.UsedRange.Value2

    Dim ResetDisplayAlerts As Boolean
    ResetDisplayAlerts = Application.DisplayAlerts
    Application.DisplayAlerts = False
    TempSheet.Delete
    Application.DisplayAlerts = ResetDisplayAlerts
End Function

请注意，由于临时工作表的原因，替代方案 2 更有可能失败。我认为替代方案 1 更稳健。