excel - 危机:对帐宏-每次都挂起Excel 2010

Question

晚上好。

两个月前，我开始在Excel 2010中开发宏，其目的是协调两组不同的信息。我在一个月前暂停了该项目，此时宏可以仔细检查每一行信息，而不会引起任何投诉。

几天前，我恢复了该项目的工作，并实施了一些非常小的使用长数组的方法，以包含满足特定条件的行的位置。现在，每次尝试运行宏时，Excel都会卡在我身上，这真是令人毛骨悚然的体验。只要我没做得太快，就可以单步执行代码，但是第二步让它自己运行会导致崩溃。状态栏更新是主循环的一部分，它告诉我宏在停止响应之前设法处理了大约1％的行。

据我所知，这是一个令人难以置信的令人沮丧的问题，根本不应该发生，并且一定是由于处理大量数据时对Excel施加了一些限制。也许它将我的循环解释为无限循环？

有一个贯穿两个数据集之一的总体循环，它包含一个贯穿第二数据集的较小部分以查找匹配项的第二循环。在崩溃开始之前，宏能够处理大约是我现在使用的数据集大小的11倍的数据集。将数据集的当前大小减小到上述默认值的大约10％仍会导致宏挂起Excel，但有趣的是，它设法处理了11％的数据。由此得出的明智结论是，数据集中某处存在一条实际数据，以某种方式导致Excel挂起，但是1):如果是这种情况，我会期望收到一条错误消息，以及2)检查数据集约占1％的成分并没有导致特别发现。

所以我转向你。我衷心希望您能提出一些建议，以解决此问题以及如何解决该问题。

这是有问题的子过程:http://pastebin.com/ywacHTVN

我一直想知道是否将其拆分为几个子过程，以使其对于Excel更易消化，从而解决我的问题？如果是这样的话，如果有人可以向我解释原因，我将不胜感激。

我想我应该提到一些重要的事情:早些时候，我写道，在实现少量使用数组之前，宏能够处理比当前数据集大11倍的数据集而没有任何问题。但这只是在我添加了定期的执行-每当StatusBar更新时-就执行了DoEvents。在此之前，Excel会像现在一样挂起。

Sub MainRecon()

Dim row_MSPS As Long, row_FPMS As Long, rowStart_FPMS As Long, rowEnd_FPMS As Long, row_FPMS_lastMatch As Long
Dim row_midFPMS As Long, row_midMSPS As Long, IMO_Number As Long, size_MSPS As Long, row_MSPS_next As Long
Dim n_matches As Integer, I_sup As Integer, temp_FPMS_Row As Long

Dim match_Array() As Long
Dim supreme_match_Array() As Long: ReDim supreme_match_Array(30)
Dim IMO_FPMS_Pos_Array() As Long: ReDim IMO_FPMS_Pos_Array(30)

Dim row_first_FPMS As Integer, I As Integer, IMO_matches As Integer, supreme_Size As Integer

Dim order_no_FPMS As String

Dim match As Boolean, quantity_MSPS As Boolean, IMO_next_match As Boolean, stock_update As Boolean
Dim MSPS_duplicate As Boolean, FPMS_noMatches As Boolean, empty_FPMS As Boolean

Dim deliveryDate_MSPS As Date, deliveryDate_FPMS As Date, deliveryDate_MSPS_next As Date


row_MSPS = 2
row_FPMS = 2

row_midFPMS = 3
row_midMSPS = 3

size_MSPS = 2

'Index for supreme match array.
I_sup = 0

Do While MSPS_RawWS.Cells(size_MSPS, 1) <> ""
    size_MSPS = size_MSPS + 1
Loop


MainProcedure:
Do While MSPS_RawWS.Cells(row_MSPS, 1) <> "" 'Stops at the end of the records

    'Boolean variables defined
    empty_FPMS = False
    match = False
    quantity_MSPS = False
    IMO_next_match = False
    stock_update = False
    FPMS_noMatches = False

    If IsNumeric(Left(MSPS_RawWS.Cells(row_MSPS, 7), 2)) = True _
        And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS, 7), 4, 2)) = True _
        And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS, 7), 7, 4)) = True Then 'Confirms date format DD-MM-YYYY of 'Time for Bunker' of MSPS

        'Crew updated stock by reporting a new delivery instead of following proper procedure.
        'Stock-Delivery difference smaller than 60 will be picked up as a stock update
        'as well as delivery quantities under 10 [mt]
        If ((60 > Abs(MSPS_RawWS.Cells(row_MSPS, 6) - MSPS_RawWS.Cells(row_MSPS, 8)) And _
            Abs(MSPS_RawWS.Cells(row_MSPS, 6) - MSPS_RawWS.Cells(row_MSPS, 8)) >= 0) Or (0 < MSPS_RawWS.Cells(row_MSPS, 8) And MSPS_RawWS.Cells(row_MSPS, 8) <= 10)) And _
            (MSPS_RawWS.Cells(row_MSPS, 6) + MSPS_RawWS.Cells(row_MSPS, 8) > 0) Then

                    MSPS_RawWS.Range("A" & row_MSPS, "H" & row_MSPS).Copy
                    mid_ReportWS.Cells(row_midMSPS, 11).PasteSpecial

                    mid_ReportWS.Cells(row_midMSPS, 9) = "Error 40. Updated stock reported as delivery."

                    row_midMSPS = row_midMSPS + 1
                    row_midFPMS = row_midFPMS + 1

                    Call UpdateProgress("", 4, row_MSPS, size_MSPS)


        Else 'Proceed if it passes the stock update check

            Call UpdateProgress("", 4, row_MSPS, size_MSPS)

            quantity_MSPS = False

            If MSPS_RawWS.Cells(row_MSPS, 8) > 0 Then 'If MSPS quantity is above 0, proceed

            quantity_MSPS = True

                If IsNumeric(Left(MSPS_RawWS.Cells(row_MSPS, 7), 2)) = True _
                And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS, 7), 4, 2)) = True _
                And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS, 7), 7, 4)) = True Then 'Confirms date format DD-MM-YYYY

                deliveryDate_MSPS = Left(MSPS_RawWS.Cells(row_MSPS, 7), 10) 'Cuts away HH:MM:SS
                IMO_Number = MSPS_RawWS.Cells(row_MSPS, 2)

                'Finds the next MSPS record with quantity and date.
                row_MSPS_next = row_MSPS + 1
                Do While (MSPS_RawWS.Cells(row_MSPS_next, 7) = "" Or Not MSPS_RawWS.Cells(row_MSPS_next, 8) > 0) And row_MSPS_next <= size_MSPS _
                And Not (IsNumeric(Left(MSPS_RawWS.Cells(row_MSPS_next, 7), 2)) = True _
                And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS_next, 7), 4, 2)) = True _
                And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS_next, 7), 7, 4)) = True)

                    row_MSPS_next = row_MSPS_next + 1

                Loop


                'Checks if the next MSPS record has an IMO that matches the current one, and gets the date of the next record
                IMO_next_match = False
                If IMO_Number = MSPS_RawWS.Cells(row_MSPS_next, 2) And (IsNumeric(Left(MSPS_RawWS.Cells(row_MSPS_next, 7), 2)) = True _
                And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS_next, 7), 4, 2)) = True _
                And IsNumeric(Mid(MSPS_RawWS.Cells(row_MSPS_next, 7), 7, 4)) = True) And MSPS_RawWS.Cells(row_MSPS_next, 8) > 0 Then

                    deliveryDate_MSPS_next = Left(MSPS_RawWS.Cells(row_MSPS_next, 7), 10)
                    IMO_next_match = True

                End If

                'Checks if the MSPS record is a duplicate
                If IMO_next_match = True And deliveryDate_MSPS = deliveryDate_MSPS_next And _
                MSPS_RawWS.Cells(row_MSPS, 8) = MSPS_RawWS.Cells(row_MSPS_next, 8) Then

                            MSPS_RawWS.Range("A" & row_MSPS, "H" & row_MSPS).Copy
                            mid_ReportWS.Cells(row_midMSPS, 11).Paste

                            mid_ReportWS.Cells(row_midMSPS, 9) = "Duplicate entry."

                            row_midMSPS = row_midMSPS + 1
                            row_midFPMS = row_midFPMS + 1

                            Call UpdateProgress("", 4, row_MSPS, size_MSPS)

                            row_MSPS = row_MSPS + 1

                            'Proceed prematurely to the next iteration in the all-encompassing 'Do While'-loop
                            'if the current MSPS-record is a duplicate
                            GoTo MainProcedure
                End If

                match = False
                row_first_FPMS = 0

                    Do While IsEmpty(FPMS_RawWS.Cells(row_FPMS, 1)) = False And (IMO_Number > FPMS_RawWS.Cells(row_FPMS, 1) _
                    Or IMO_Number = FPMS_RawWS.Cells(row_FPMS, 1)) 'Search for FPMS records with matching IMO number

                        If IMO_Number = FPMS_RawWS.Cells(row_FPMS, 1) Then

                            If row_first_FPMS > 0 Then
                                If FPMS_RawWS.Cells(row_first_FPMS, 1) <> FPMS_RawWS.Cells(row_FPMS, 1) Then

                                    row_first_FPMS = row_FPMS 'This is the very first of the matching FPMS records
                                    'For use later in connection with the arrays.

                                End If

                            Else

                                row_first_FPMS = row_FPMS

                            End If


                            If deliveryDate_MSPS = FPMS_RawWS.Cells(row_FPMS, 5) Or deliveryDate_MSPS = FPMS_RawWS.Cells(row_FPMS, 5) - 1 Or deliveryDate_MSPS = FPMS_RawWS.Cells(row_FPMS, 5) + 1 Then

                                match = True

                                Exit Do

                            End If
                        End If

                        row_FPMS = row_FPMS + 1

                    Loop

                If match = True Then

                'The following array will contain the location (row) of all FPMS records matching the current MSPS record
                ReDim match_Array(30)

                match_Array(0) = row_FPMS
                n_matches = 1

                row_FPMS_lastMatch = row_FPMS
                order_no_FPMS = FPMS_RawWS.Cells(row_FPMS, 4)

                rowStart_FPMS = row_FPMS 'Multiple entries can exist in FPMS for a single entry in MSPS. This is the lower boundary

                row_FPMS = row_FPMS + 1

                Do While IMO_Number = FPMS_RawWS.Cells(row_FPMS, 1)

                    'The FPMS order numbers are made up of 8 ciphers: XXXXXXXN
                    'The 7 first ciphers are used to tie orders together. MSPS usually has a single entry for all FPMS
                    'entries under XXXXXXX.
                    If Left(order_no_FPMS, 7) = Left(FPMS_RawWS.Cells(row_FPMS, 4), 7) And order_no_FPMS = FPMS_RawWS.Cells(row_FPMS, 4) Then

                        match_Array(n_matches) = row_FPMS
                        n_matches = n_matches + 1

                        row_FPMS = row_FPMS + 1

                    ElseIf deliveryDate_MSPS = FPMS_RawWS.Cells(row_FPMS, 5) Or deliveryDate_MSPS = FPMS_RawWS.Cells(row_FPMS, 5) - 1 Or deliveryDate_MSPS = FPMS_RawWS.Cells(row_FPMS, 5) + 1 Then

                        match_Array(n_matches) = row_FPMS
                        n_matches = n_matches + 1

                        row_FPMS = row_FPMS + 1

                        'If the next valid MSPS record is on the date after the current one, and the next FPMS record is as well, exit loop
                        If IMO_next_match = True And deliveryDate_MSPS_next = FPMS_RawWS.Cells(row_FPMS, 5) Then

                            Exit Do

                        End If

                    End If
                    Loop

                    'Upper boundary of range.
                    rowEnd_FPMS = row_FPMS - 1

                    If n_matches = 1 Then

                        FPMS_RawWS.Range("A" & match_Array(0), "H" & match_Array(0)).Copy
                        mid_ReportWS.Cells(row_midFPMS, 1).PasteSpecial

                        MSPS_RawWS.Range("A" & row_MSPS, "H" & row_MSPS).Copy
                        mid_ReportWS.Cells(row_midMSPS, 11).PasteSpecial

                    ElseIf n_matches > 1 Then

                        For I = 0 To n_matches - 1

                            FPMS_RawWS.Range("A" & match_Array(I), "H" & match_Array(I)).Copy
                            mid_ReportWS.Range("A" & row_midFPMS + I).PasteSpecial

                        Next I

                        MSPS_RawWS.Range("A" & row_MSPS, "H" & row_MSPS).Copy
                        mid_ReportWS.Range("K" & row_midMSPS).PasteSpecial

                    End If

                    'Next free rows in mid-report
                    row_midMSPS = row_midMSPS + n_matches
                    row_midFPMS = row_midFPMS + n_matches

                    'The supreme_match_Array contains the row-position of all FPMS records that have been matched with an MSPS partner
                    'Empty the contents of the match_Array into the supreme array.
                    'The match_Array is recycled for every MSPS record - not every IMO number.

                    I = 0

                    Do Until match_Array(I) = 0

                        supreme_match_Array(I_sup) = match_Array(I)

                        I_sup = I_sup + 1
                        I = I + 1

                    Loop


                    'When the next MSPS record has a different IMO number than the current one, check supreme_match_Array against IMO_FPMS_Pos_Array
                    'to find out which FPMS records have not been paired with their MSPS counterparties, and copy these to the mid-report.
                    If IMO_next_match = False Then

                        temp_FPMS_Row = row_first_FPMS

                        IMO_matches = 0

                        'Find position of all FPMS records with matching IMO, and save this
                        Do While IMO_Number = FPMS_RawWS.Cells(temp_FPMS_Row, 1)

                            IMO_matches = IMO_matches + 1

                            IMO_FPMS_Pos_Array(IMO_matches - 1) = temp_FPMS_Row

                            temp_FPMS_Row = temp_FPMS_Row + 1

                        Loop

                        supreme_Size = 0

                        Do While supreme_match_Array(supreme_Size) > 0 'Find size of array

                            supreme_Size = supreme_Size + 1

                        Loop


                        For I = 0 To IMO_matches - 1

                            For I_sup = 0 To supreme_Size - 1

                                If IMO_FPMS_Pos_Array(I) = supreme_match_Array(I_sup) Then

                                    IMO_FPMS_Pos_Array(I) = 0
                                    GoTo NextIteration_I

                                End If

                            Next I_sup
NextIteration_I:
                        Next I

                        For I = 0 To IMO_matches - 1

                            If IMO_FPMS_Pos_Array(I) > 0 Then

                                FPMS_RawWS.Range("A" & IMO_FPMS_Pos_Array(I), "H" & IMO_FPMS_Pos_Array(I)).Copy
                                mid_ReportWS.Cells(row_midFPMS, 1).PasteSpecial

                                mid_ReportWS.Cells(row_midFPMS, 9).Hyperlinks.Add Anchor:=mid_ReportWS.Cells(row_midFPMS, 9), Address:="", SubAddress:= _
                               "'MSPS Raw'!A" & row_MSPS & ":R" & row_MSPS, TextToDisplay:="FPMS missing MSPS counter."


'                                Cells(row_midFPMS, 9).Select
'                                ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
'                                "'MSPS Raw'!A" & row_MSPS & ":R" & row_MSPS, TextToDisplay:="FPMS missing MSPS counter."

                                row_midFPMS = row_midFPMS + 1

                                FPMS_noMatches = True

                            End If

                        Next I

                        If FPMS_noMatches = True Then

                            'Next free rows in mid-report
                            row_midMSPS = row_midFPMS

                            FPMS_noMatches = False

                        End If

                        'The supreme array should be purged since we are moving on to another IMO-number
                        ReDim supreme_match_Array(30)
                        I_sup = 0

                    End If

            ElseIf quantity_MSPS = True Then


                        Sheets("MSPS Raw").Activate
                        Range("A" & row_MSPS, "H" & row_MSPS).Copy
                        Sheets("Mid-Report").Activate
                        Cells(row_midMSPS, 11).Select
                        ActiveSheet.Paste

                        'Cells(row_midMSPS, 9) = "MSPS missing partner."

                        Cells(row_midMSPS, 9).Select
                        ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
                        "'FPMS Raw'!A" & row_FPMS_lastMatch & ":R" & row_FPMS_lastMatch, TextToDisplay:="MSPS missing partner."

                        row_midMSPS = row_midMSPS + 1
                        row_midFPMS = row_midFPMS + 1

                        row_FPMS = row_FPMS_lastMatch + 1


            End If 'Match check
            End If 'Date check
            End If 'Quantity > 0 check
    End If 'Error 40: Stock Update
    End If 'Date format check

    row_MSPS = row_MSPS + 1

Loop

End Sub

编辑:更改数据集的大小没有任何区别。无论数据集包含超过6000行还是仅包含200行，它在崩溃前仍然只能协调5-7行。

Answer 1

啊，基督，我真愚蠢。我不小心从Do While循环中删除了步骤语句。抱歉浪费您的时间。不过，由于克里斯建议的变量数组，我的代码现在比以往任何时候都运行得更快。