Добрый вечер.Кризис: макрос сверки - Excel 2010 висит каждый раз
Два месяца назад я начал разработку макроса в Excel 2010 с целью согласования двух разных наборов информации. Я положил проект на удержание месяц назад, и в этот момент макрос мог прожевать каждую строку информации без каких-либо жалоб.
Несколько дней назад я возобновил свою работу над проектом, и я реализовал очень малое использование длинного массива, чтобы содержать позиции строк, которые отвечают определенным критериям. Теперь это привело к тому, что у меня все время разрывается прическа, и я пытаюсь запустить макрос. Выполнить код можно без каких-либо проблем, если я не делаю этого слишком быстро, но второй, который я позволяю ему запускать самостоятельно, сбой. Обновление строки состояния является частью основного цикла, и он сообщает мне, что макросу удается обработать приблизительно 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
EDIT: Изменение размера наборов данных не имеет значения. Ему все еще удается примирить 5-7 строк перед сбоем, независимо от наборов данных, состоящих из более чем 6000 строк или всего всего 200 строк.
Если вы открываете диспетчер задач, есть ли какие-либо процессы, сидящие на высоком проценте? Как насчет использования файла страницы? Я боюсь, что Excel имеет ограничение «масштабируемости».Я предполагаю, что вы загружаете всю загрузку записей из базы данных (или отчет запускается из базы данных), а затем обрабатываете их в макросе Excel? Возможно, настало время переместить обработку в базу данных. –
Только 12% процессора используется во время прослушивания Excel, и имеется более чем достаточно физической и виртуальной памяти. Вы отчасти исправляете импорт данных из базы данных, но это будет не так, пока он не появится на производстве. Так как сейчас я только что импортировал данные набора данных вручную, поэтому взаимодействие с базой данных не происходит, и никаких операций ввода-вывода не происходит. Я очень надеюсь, что я не натолкнулся на потолок Excel. Наборы данных не более 1700x4 и 4500x6. И, как я уже упоминал, резкое уменьшение размера наборов данных не имеет никакого значения. – KHH
Учитывая ваше подозрение в данных, я предлагаю вам поместить строку «kamikaze» в ваш код, которая останавливается на произвольном номере записи, и продолжайте изменять это, пока не сможете убедиться, что это конкретная запись, вызывающая проблему. В качестве альтернативы, он не может висеть на той же записи каждый раз, что подразумевает, что оно не основано на данных. –