vba - CopyMemory 使 Excel 应用程序崩溃

Question

首先介绍一下背景。
我正在尝试合并多个二维数组。通常我会循环遍历新数组的每个元素并将它们添加到现有数组中或将数组的值放在单独的工作表上并从中创建新数组，但我正在处理大数据。
不久前，我发现了 CopyMemory 函数，并对它感到非常兴奋，我首先在简单的数据 block 上测试了它。

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就会崩溃(它不会识别错误，但会警告出现问题(感谢 cap))。
我唯一能想到的是新数据中有字符串。
每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

在监 window 口中，我可以清楚地看到合并成功，但在 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