vba – CopyMemory崩溃Excel应用程序

2023年10月10日 434次阅读

首先是一点背景.

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

不久前我发现了CopyMemory功能并且真的很兴奋,我先在简单的数据块上测试过它.

《vba – CopyMemory崩溃Excel应用程序》

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再次崩溃后不久.

最佳答案 我只能猜测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
点赞