晚上好。
两个月前，我开始在 Excel 2010 中开发一个宏，目的是协调两组不同的信息。我在一个月前搁置了这个项目，此时宏可以毫无怨言地浏览每一行信息。
几天前我恢复了我的项目工作，我实现了一些非常小的使用长数组来包含满足特定条件的行的位置。现在，这导致了每次尝试运行宏时都让 Excel 挂在我身上的令人毛骨悚然的体验。只要我不做得太快，单步执行代码就可以毫无问题地完成，但是第二次我让它自己运行它就会崩溃。状态栏更新是主循环的一部分，它告诉我宏在停止响应之前设法处理了大约 1% 的行。
这是一个令人难以置信的令人沮丧的问题，因为它 - 据我所知 - 根本不应该发生，并且必须是由于在处理大量数据时对 Excel 施加的一些限制。也许它将我的循环解释为无限循环？
有一个贯穿两个数据集之一的总体循环，它包含第二个循环，该循环贯穿第二个数据集的相对较小部分以查找匹配项。在崩溃开始发生之前，该宏能够处理大约是我现在使用的数据集大小的 11 倍的数据集。将数据集的当前大小减少到上述默认值的 10% 左右仍会导致宏使 Excel 挂起，但有趣的是，它设法处理了 11% 的数据。从中得出的明智结论是，数据集中某处的实际数据以某种方式导致 Excel 挂起，但是 1）：如果是这种情况，我会收到一条错误消息，以及 2）检查数据集大约构成 1% 的人并没有导致任何非凡的发现。
所以我转向你。我真诚地希望您能就可能导致此问题的原因以及我如何尝试解决它提出一些建议。
这是有问题的子程序： http: //pastebin.com/ywacHTVN
我一直想知道是否将其拆分为几个子程序会使 Excel 更易于消化，从而解决我的问题？如果是这种情况，如果有人可以向我解释原因，我将不胜感激。
我想我应该提到一些重要的事情：在我实现对数组的少量使用之前，我之前写过宏能够毫无问题地处理比当前数据大 11 倍的数据集。但这只是在我添加了 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
编辑：更改数据集的大小没有任何区别。它仍然只能在崩溃之前协调 5-7 行，无论数据集总共包含超过 6000 行，还是总共只有 200 行。