晚上好。
两个月前，我开始在Excel 2010中开发一个宏，目的是协调两组不同的信息。我在一个月前暂停了这个项目，此时宏可以在没有任何投诉的情况下咀嚼每一行信息。
几天前，我恢复了对项目的工作，并且我实现了一些非常小的长数组使用，以包含符合特定条件的行的位置。现在这已经导致了每次尝试运行宏时Excel都挂在我身上的头发撕裂体验。单步执行代码可以毫无问题地完成，只要我不执行它太快，但第二个我让它自己运行它崩溃。状态栏更新是主循环的一部分，它告诉我宏在它停止响应之前设法处理大约1％的行。
这是一个令人难以置信的令人沮丧的问题，因为它 - 据我所知 - 根本不应该发生，并且必须归因于在处理大量数据时对Excel施加的某些限制。也许它将我的循环解释为无限循环？
有一个遍历两个数据集之一的遍历循环，它包含第二个循环，该循环遍历第二个数据集的相对较小的部分以查找匹配项。在崩溃开始发生之前，宏能够处理大约是我现在使用的数据集大小的11倍的数据集。将数据集的当前大小减小到上述默认值的大约10％仍会导致宏挂起，但有趣的是它设法处理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
编辑：更改数据集的大小没有任何区别。它仍然只能在崩溃之前协调5-7行，无论总共超过6000行的数据集，还是总共只有200行。
答案 0 :(得分：0)