我的问题是：

Question

首先是背景。
我正在尝试合并多个2D数组。 Usualy我会循环遍历新数组的每个元素并将它们添加到现有数组或将数组的值放在单独的工作表上并从中创建新数组但我正在处理大数据。
不久前，我发现了CopyMemory功能，并对它感到非常兴奋，我先在简单的数据块上进行了测试。

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Sub Test()
    Dim varr0(), varr1(), Border As Long
    varr0 = Application.Transpose(Range("a1").CurrentRegion.Value)
    Border = UBound(varr0, 2)
    varr1 = Application.Transpose(Range("a21").CurrentRegion.Value)
    ReDim Preserve varr0(1 To UBound(varr0, 1), 1 To UBound(varr0, 2) + UBound(varr1, 2))
    CopyMemory varr0(1, Border + 1), varr1(1, 1), UBound(varr1, 1) * UBound(varr1, 2) * 16
    Range(Cells(1, 10), Cells(1, 10).Offset(UBound(varr0, 2) - 1, UBound(varr0, 1) - 1)).Value = Application.Transpose(varr0)
End Sub

显然这是成功的（或者我认为），我决定使用我的实际数据，从那里开始走下坡路。

Sub Test_2()
    Dim varr0(), varr1(), Border As Long, ws As Worksheet
    varr0 = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("a1").CurrentRegion.Value)
    Border = UBound(varr0, 2)
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
            varr1 = Application.Transpose(ws.Range("a1").CurrentRegion.Value)
            ReDim Preserve varr0(1 To UBound(varr0), 1 To UBound(varr0) + UBound(varr1))
            CopyMemory varr0(1, Border + 1), varr1(1, 1), UBound(varr1, 1) * UBound(varr1, 2) * 16
            Border = UBound(varr0, 2)
        End If
    Next
    ThisWorkbook.Worksheets("ws1").Range(Cells(1, 11), Cells(1, 11).Offset(UBound(varr0, 2) - 1, UBound(varr0, 1) - 1)).Value = Application.Transpose(varr0)
End Sub

每当我执行它时，Excel崩溃（它不会识别错误但会发出错误警告（感谢上限））。
我唯一能想到的是新数据中有字符串每Source Variant只需要16个字节。

我的问题是：

如何让它按预期工作？
我的逻辑有什么缺陷导致Excel崩溃？
是否可以合并两个数组
- 循环（或至少不遍历整个数组）
- 使用床单

更新

似乎我在计算内存以便错误地复制，所以我稍微修改了我的宏。

Sub Test_6()
    Dim varr0(), varr1(), Border As Long, ws As Worksheet, MemUsage As Long
    varr0 = Application.Transpose(ThisWorkbook.Worksheets("Sheet1").Range("a1").CurrentRegion.Value)
    Border = UBound(varr0, 2)
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
            varr1 = Application.Transpose(ws.Range("a1").CurrentRegion.Value)
            ReDim Preserve varr0(1 To UBound(varr0, 1), 1 To UBound(varr0, 2) + UBound(varr1, 2))
            MemUsage = VarPtr(varr1(UBound(varr1, 1), UBound(varr1, 2))) - VarPtr(varr1(1, 1))
            CopyMemory varr0(1, Border + 1), varr1(1, 1), MemUsage + 16 + Len(varr1(UBound(varr1, 1), UBound(varr1, 2)))
            Border = UBound(varr0, 2)
        End If
    Next
    ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, 11), Cells(1, 11).Offset(UBound(varr0, 2) - 1, UBound(varr0, 1) - 1)).Value = Application.Transpose(varr0)
End Sub

在观察窗口中，我可以清楚地看到合并成功，但在CopyMemory行Excel再次崩溃后不久。

Answer 1

我只能猜测API正在读取内存中连续的字节范围，而操作系统可能会在分割位置存储大部分数据。请记住，VBA正在使用API来完成其工作。一旦你覆盖VBA并尝试更好地完成同样的工作，你就会有举证责任。

以下代码会将任何源的非连续范围的值写入它创建的工作表中。请注意，范围的数量是无限的，但是是硬编码的。

Private Sub TestAppend()
    ' 17 Nov 2017

    Dim WsS As Worksheet, WsT As Worksheet          ' Source and Target
    Dim Arr() As Variant
    Dim Rl As Long                                  ' last row
    Dim i As Long

    Set WsS = ActiveSheet
    On Error Resume Next
    Set WsT = Worksheets("Temp")
    If Err Then
        Set WsT = Worksheets.Add(Sheet1)
        WsT.Name = "Temp"
    End If
    On Error GoTo 0

    ReDim Arr(1)
    Arr(0) = Range("A1").CurrentRegion.Value
    Arr(1) = Range("E1").CurrentRegion.Value

    For i = 0 To UBound(Arr)
        With WsT
            Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
            .Cells(Rl, "A").Resize(UBound(Arr(i)), UBound(Arr(i), 2)).Value = Arr(i)
        End With
    Next i
End Sub

CopyMemory崩溃Excel应用程序

我的问题是：

更新

1 个答案: