32位版本的VBA

Question

我已经编写了一些代码来在excel中生成报告。在开发过程中，我使用了64位Windows和64位版本的Excel。代码可以完美运行，但我的用户使用32位Windows和Excel。这些会带来错误＆＃34; Not enough memory＆＃34;。我的代码有些For..Loop函数和数组。我试图通过不使用数组来解决问题。但它仍然无法正常工作，同样的错误仍然存​​在。你有什么建议吗？

我的Excel文件和数据集可用on Github here。错误文件名Report_Generate.xlsm和报告名称Risk_Loss_Report.xlsm

的数据源

这是我收到错误的部分。请注意，这部分代码可以在Excel 64 bit版本上运行良好。 Excel 32 bit中出现内存问题。

Sub Allocate(LET_NEU, NEU)

    Dim Info As String
    Info = NEU
    Dim LetData As String
    LetData = LET_NEU
    Dim i As Integer

    'Check total record of sheet . If >= 2 record , do
    Dim TotalRecord As Integer
    TotalRecord = Worksheets(Info).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
    If TotalRecord >= 2 Then
        Dim R As Integer
        For R = 2 To TotalRecord
            'Check Dept
            Dim deptCurrent As String
            Dim deptPrevious As String
            deptCurrent = "AV" & R
            deptPrevious = "AV" & R - 1
            Dim DeptCurVal As String
            Dim DeptPreVal As String
            DeptCurVal = Sheets(Info).Range(deptCurrent)
            DeptPreVal = Sheets(Info).Range(deptPrevious)
            If DeptCurVal <> DeptPreVal Then
                'Create header
                Dim RinLet As Integer
                Windows("Total Event By Department.xlsx").Activate

                Sheets(LetData).Select
                Dim countmerge As Integer
                Sheets(LetData).Range("A:A").Select
                countmerge = ActiveCell.MergeArea.Cells.Count

                RinLet = Sheets(LetData).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

                Dim DeptTH As String
                Dim RLOS As String
                Dim RLOS_Email As String
                Dim RangeDept As String
                RangeDept = "BG" & R
                DeptTH = Sheets(Info).Range(RangeDept).Value
                Dim RangeRLOS As String
                RangeRLOS = "BA" & R
                RLOS = "ª×èͼÙé»ÃÐÊÒ¹§Ò¹¤ÇÒÁàÊÕè§ (RLOs) :" & Sheets(Info).Range(RangeRLOS).Value
                Dim RangeRLOS_Email As String
                RangeRLOS_Email = "BB" & R
                RLOS_Email = "Lotus Notes :" & Sheets(Info).Range(RangeRLOS_Email).Value

                '....................................................
                Windows("Total Event By Department.xlsx").Activate
                Sheets(LetData).Select
                Sheets(LetData).Range("A:A").Select
                countmerge = ActiveCell.MergeArea.Cells.Count

                RinLet = Sheets(LetData).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

                'Format Header
                Dim RDept As String
                Dim NumCal As Integer

                RDept = "A" & RinLet + 1

                Sheets(LetData).Range(RDept).Value = DeptTH
                Dim MergeA As String
                MergeA = RDept & ":C" & RinLet + 1
                Dim MergeD As String
                MergeD = "D" & RinLet + 1 & ":G" & RinLet + 1
                Dim MergeH As String
                MergeH = "H" & RinLet + 1 & " :AS" & RinLet + 1
                Sheets(LetData).Select
                Sheets(LetData).Range(MergeA).Select
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With
                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 49407
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With

                Sheets(LetData).Range(MergeD).Select
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With

                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 49407
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With

                Sheets(LetData).Range(MergeH).Select
                With Selection
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
                End With

                With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .Color = 49407
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                End With

                ' Add Value to Info to Header
                Dim RRLOS As String
                RRLOS = "D" & RinLet + 1
                Sheets(LetData).Range(RRLOS).Value = RLOS
                Dim RRLOS_Email As String
                RRLOS_Email = "H" & RinLet + 1
                Sheets(LetData).Range(RRLOS_Email).Value = RLOS_Email

                ' Copy detail
                Dim CopyRange2 As String
                CopyRange2 = "A" & R & ":AS" & R
                Dim LetRow As String
                LetRow = "A" & RinLet + 2 & ":AS" & RinLet + 2
                Worksheets(LetData).Range(LetRow).Value = Worksheets(Info).Range(CopyRange2).Value

            Else
                'Copy Detail
                Dim RLet2 As Integer
                RLet2 = Sheets(LetData).Cells(Sheets(LetData).Rows.Count, "A").End(xlUp).Row
                Dim RangeNEU As String
                RangeNEU = "A" & R & ":AS" & R
                Dim LetRow2 As String
                LetRow2 = "A" & RLet2 + 1 & ":AS" & RLet2 + 1
                Worksheets(LetData).Range(LetRow2).Value = Worksheets(Info).Range(RangeNEU).Value

            End If

        Next R

    End If

    'Windows("Risk_Loss_Report.xlsm").Activate
    'ActiveWindow.Close

End Sub

Answer 1

我还没有改变你的逻辑，但我已将所有Dim合并到声明区域并从thre循环中删除它们。虽然你根据我的口味使用了太多的变量，但我按原样保留了它们。

我还删除了所有.Activate和.Select部分。这会占用大量资源并大大降低代码速度。

这是您重新编写的代码，已清理并正确缩进。请仔细看看这些变化。

Sub Allocate(LET_NEU, NEU)

Dim Info As String
Dim LetData As String
Dim i As Integer, TotalRecord As Integer, R As Integer
Dim deptCurrent As String, deptPrevious As String, DeptCurVal As String, DeptPreVal As String
Dim RinLet As Integer, countmerge As Integer
Dim DeptTH As String, RLOS As String, RLOS_Email As String, RangeDept As String
Dim RangeRLOS As String, RangeRLOS_Email As String
Dim RDept As String, NumCal As Integer
Dim MergeA As String, MergeD As String, MergeH As String
Dim RRLOS As String, RRLOS_Email As String
Dim CopyRange2 As String, LetRow As String
Dim RLet2 As Integer, RangeNEU As String, LetRow2 As String
Dim wBook As Workbook

Info = NEU
LetData = LET_NEU

Application.ScreenUpdating = False

'Check total record of sheet . If >= 2 record , do

TotalRecord = Worksheets(Info).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count
If TotalRecord >= 2 Then
    For R = 2 To TotalRecord
        'Check Dept
        deptCurrent = "AV" & R
        deptPrevious = "AV" & R - 1
        DeptCurVal = Sheets(Info).Range(deptCurrent)
        DeptPreVal = Sheets(Info).Range(deptPrevious)
        If DeptCurVal <> DeptPreVal Then
            'Create header
            Set wBook = Windows("Total Event By Department.xlsx").ActiveSheet.Parent
            countmerge = wBook.Sheets(LetData).Range("A:A").MergeArea.Cells.Count

            RinLet = Sheets(LetData).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count


            RangeDept = "BG" & R
            DeptTH = Sheets(Info).Range(RangeDept).Value
            RangeRLOS = "BA" & R
            RLOS = "ª×èͼÙé»ÃÐÊÒ¹§Ò¹¤ÇÒÁàÊÕè§ (RLOs) :" & Sheets(Info).Range(RangeRLOS).Value
            RangeRLOS_Email = "BB" & R
            RLOS_Email = "Lotus Notes :" & Sheets(Info).Range(RangeRLOS_Email).Value
            '....................................................
            Set wBook = Windows("Total Event By Department.xlsx").ActiveSheet.Parent
            countmerge = wBook.Sheets(LetData).Range("A:A").MergeArea.Cells.Count

            RinLet = Sheets(LetData).Range("A:A").Cells.SpecialCells(xlCellTypeConstants).Count

            'Format Header

            RDept = "A" & RinLet + 1

            Sheets(LetData).Range(RDept).Value = DeptTH

            MergeA = RDept & ":C" & RinLet + 1
            MergeD = "D" & RinLet + 1 & ":G" & RinLet + 1
            MergeH = "H" & RinLet + 1 & " :AS" & RinLet + 1

            With Sheets(LetData).Range(MergeA)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
                .WrapText = False
                .Orientation = 0
                .AddIndent = False
                .IndentLevel = 0
                .ShrinkToFit = False
                .ReadingOrder = xlContext
                .MergeCells = True
            End With
            With Sheets(LetData).Range(MergeA).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 49407
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

            With Sheets(LetData).Range(MergeD)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
            End With
            With Sheets(LetData).Range(MergeD).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 49407
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

            With Sheets(LetData).Range(MergeH)
                    .HorizontalAlignment = xlCenter
                    .VerticalAlignment = xlCenter
                    .WrapText = False
                    .Orientation = 0
                    .AddIndent = False
                    .IndentLevel = 0
                    .ShrinkToFit = False
                    .ReadingOrder = xlContext
                    .MergeCells = True
            End With
            With Sheets(LetData).Range(MergeH).Interior
                .Pattern = xlSolid
                .PatternColorIndex = xlAutomatic
                .Color = 49407
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With

            ' Add Value to Info to Header
            RRLOS = "D" & RinLet + 1
            Sheets(LetData).Range(RRLOS).Value = RLOS
            RRLOS_Email = "H" & RinLet + 1
            Sheets(LetData).Range(RRLOS_Email).Value = RLOS_Email

            ' Copy detail
            CopyRange2 = "A" & R & ":AS" & R
            LetRow = "A" & RinLet + 2 & ":AS" & RinLet + 2
            Worksheets(LetData).Range(LetRow).Value = Worksheets(Info).Range(CopyRange2).Value

        Else
            'Copy Detail
            RLet2 = Sheets(LetData).Cells(Sheets(LetData).Rows.Count, "A").End(xlUp).Row
            RangeNEU = "A" & R & ":AS" & R
            LetRow2 = "A" & RLet2 + 1 & ":AS" & RLet2 + 1
            Worksheets(LetData).Range(LetRow2).Value = Worksheets(Info).Range(RangeNEU).Value
        End If
    Next R
End If

Application.ScreenUpdating = True

End Sub