CopyMemory崩溃Excel应用程序

Question

先了解一下背景。

我正在尝试合并多个2D数组。通常，我会循环遍历新数组的每个元素，并将它们添加到现有的数组或将数组的值放在单独的工作表上，并从中创建新的数组，但我正在处理大数据。

不久前，我发现了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都会崩溃(它不能识别错误，但警告某些地方出错了(谢谢上限))。

我唯一能想到的就是新的数据中有字符串。

每个来源 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