VBA将多个范围复制到无阵列循环中

Question

我想将数据从分开的范围复制到一个没有loopnig的数组中。以下方法行不通，因为它仅使用rng1中的数据填充数组。有什么建议我可以做到这一点吗？

Dim rng1 As Range, rng2 As Range, rng3 As Range, rngMerge As Range
Dim tmpMatrixCPs_CDS() As Variant

Set WS_Ins_Mapping = ThisWorkbook.Worksheets("Instrumente_Mapping")
LastRow = WS_Ins_Mapping.Cells(rows.Count, 2).End(xlUp).Row
Set rng1 = WS_Ins_Mapping.Range(WS_Ins_Mapping.Cells(6, 2), WS_Ins_Mapping.Cells(LastRow, 2))
Set rng2 = WS_Ins_Mapping.Range(WS_Ins_Mapping.Cells(6, 26), WS_Ins_Mapping.Cells(LastRow, 26))
Set rng3 = WS_Ins_Mapping.Range(WS_Ins_Mapping.Cells(6, 36), WS_Ins_Mapping.Cells(LastRow, 36))
Set rngMerge = Union(rng1, rng2, rng3)
tmpMatrixCPs_CDS = WS_Ins_Mapping.Range(rngMerge).Value

非常感谢

Answer 1

将所有列放入数组中，然后过滤掉列：

Sub Try()
Dim tmpMatrixCPs_CDS() As Variant, x As Variant
Set WS_Ins_Mapping = ThisWorkbook.Worksheets("Instrumente_Mapping")
lastrow = WS_Ins_Mapping.Cells(Rows.Count, 2).End(xlUp).Row

x = WS_Ins_Mapping.Range(WS_Ins_Mapping.Cells(6, 1), WS_Ins_Mapping.Cells(lastrow, 36))
tmpMatrixCPs_CDS = Application.Index(x, Application.Evaluate("row(1:" & lastrow - 5 & ")"), Array(2, 26, 36))
End Sub

Answer 2

如果您希望将不相邻的列转移到数组，那么这是一个可能的选择（with credit to Mr.Excel forum）：

Sub TestMe()

    Dim rng1 As Range: Set rng1 = Range("A2:A10")
    Dim rng2 As Range: Set rng2 = Range("B2:B10")
    Dim rng3 As Range: Set rng3 = Range("C2:D10")
    Dim rngAll As Range: Set rngAll = Union(rng1, rng2, rng3)

    Dim myArr As Variant
    Dim firstRow As Long: firstRow = 1
    Dim lastRow As Long: lastRow = rngAll.Rows.Count

    Dim evalRows As Variant
    evalRows = Application.Evaluate("row(" & firstRow & ":" & lastRow & ")")

    myArr = Application.Index(rngAll, evalRows, Array(1, 3, 4))

    Dim myCol As Long, myRow As Long
    For myCol = LBound(myArr) To UBound(myArr)
        For myRow = LBound(myArr, 2) To UBound(myArr, 2)
            Debug.Print myArr(myCol, myRow)
        Next
    Next

End Sub

上面的代码有2个棘手的部分：

• 给定范围的第一行应硬编码为1；
• Application.Index(rngAll, evalRows, Array(1, 3, 4))列可以手动编写，也可以视为Rng1.Column;

---

如果范围之间没有间隙，则可以进行以下操作：

Sub TestMe()

    Dim rng1 As Range: Set rng1 = Range("A1:A10")
    Dim rng2 As Range: Set rng2 = Range("B1:B10")
    Dim rng3 As Range: Set rng3 = Range("C1:D10")
    Dim rngAll As Range: Set rngAll = Union(rng1, rng2, rng3)

    Dim myArr As Variant
    myArr = Application.Transpose(rngAll)

    Dim myCol As Long, myRow As Long

    For myCol = LBound(myArr) To UBound(myArr)
        For myRow = LBound(myArr, 2) To UBound(myArr, 2)
            Debug.Print myArr(myCol, myRow)
        Next
    Next

End Sub

Answer 3

Public Sub ArrWork()
Dim R As Range, h, i, j
Dim MyArr(1 To 3, 1 To 9) As Integer, M()
M = Array(1, 2, 4)
Set R = Range("A1:A9")
For Each i In R
    h = h + 1
    For j = 1 To 3
        MyArr(j, h) = i(1, M(j - 1))
        MsgBox MyArr(j, h)
    Next
Next
End Sub