0
兩個月前我開始在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行。
如果你打開任務管理器，有沒有高比例的進程？什麼頁面文件的使用？我擔心Excel只具有「可擴展性」限制。我猜你是從數據庫中加載一整套記錄（或者是一個報表運行數據庫），然後在Excel宏中處理它們？也可能是將處理過程移到數據庫中的時候了。 –
當Excel掛起時，只有12％的CPU正在使用，並且有足夠多的物理和虛擬內存可用。 對於從數據庫導入數據，你是部分正確的，但直到生產時纔會這樣。就像現在我剛剛手動導入數據集一樣，所以沒有與數據庫交互，也沒有任何I/O事件正在進行。 我真的希望我沒有達到Excel的上限。數據集不超過1700x4和4500x6大。正如我所提到的，大幅度縮小數據集的大小完全沒有區別。 – KHH
鑑於您對數據的懷疑，我建議您在代碼中放置一個「kamikaze」行，並停留在任意記錄編號處，並且不斷修改，直到您可以驗證它是導致問題的特定記錄。或者，它可能不會每次都掛在同一記錄上，這意味着它不是基於數據的。 –