Почему мой код VBA продолжает висит?

Question

Я приложил две ссылки на блок-схему того, как должен работать код VBA, и скриншот моих двух листов.

В принципе, у меня есть два листа - "Выплаты" & "Check Info". На листе «Расходы» мне нужно рассмотреть только строки с count> 1 (столбец I). Например, я не буду рассматривать строку 8 столбца I, но рассмотрю строку 12. Каждая строка с числом> 1 должна иметь значение в строке H к концу прогона. После того, как какая строка имеет счетчик> 1, мы проверяем, равна ли соответствующая сумма (столбец F) столбцу проверки информации E. Тогда, если, например, для строки 12 выплат, 1,384.35 равна строке 9 контрольной информации. Мы должны получить разницу этих дат, а затем сохранить ее в переменной «Текущий». Но есть много «1,384.35», что мы должны получить минимальную разницу для дат, таким образом, потребность в цикле.

Опять же, мне нужно сделать циклы для каждой строки с числом столбцов> 1 на столбцах I, так что я получу дату в Check Info (с той же суммой), которая имеет минимальный пробел от даты на листе выплат. Например, дата с наименьшим разрывом за 1/18/2016 (на сумму 1 384,35) составляет 1/4/2016.

Вот мой текущий код:

Sub F110Loop() 

Dim x As Integer 'current amount 
Dim y As Integer 
Dim d As Double 'delta between Disbursement date and Cheque Release date 
Dim Current As Integer 
Dim Least As Integer 
Dim Dis As Worksheet 
Dim Cheque As Worksheet 
Dim wb As Workbook 

Set wb = ThisWorkbook 
Set Dis = wb.Sheets("Disbursements") 
Set Cheque = wb.Sheets("Cheque Info") 
wb.Activate 

For x = 4 To 600 
    Do While Dis.Cells(x, 9).Value > 1 
     'IF same amount, get row number to get corresponding date, reference that date 
     For y = 3 To 600 
      If Dis.Cells(x, 6).Value = Cheque.Cells(y, 5).Value Then 
       'THEN get delta 
       Current = Dis.Cells(x, 4).Value -Cheque.Cells(y, 2) 
       'IF current is less than the least delta 
      ElseIf Current < Least Then 
       'THEN update new value of delta 
       Current = Least 
      Else 
       'copy paste the date (from the least delta row) 
       Cheque.Cells(y, 2).Copy Destination:=Dis.Cells(x, 8) 
      End If 
     Next y 
    Loop 
Next x 

End Sub 

Answer 1

Ваш код висит, потому что вы не имеете любой чек s для нулевой/vbnullstring или 0 значений. т.е .:

IF Dis.Cells(x,6).Value <> vbNullString OR Dis.Cells(x,6).Value <> 0 Then.... 

причина этого необходимо, чтобы держать excle от зацикливания через каждую ячейку до из памяти ...

Answer 2

Ваш Do While цикл представляет собой бесконечный цикл. Как только он поймает ячейку таким образом, что Dis.Cells(x, 9).Value > 1 будет зацикливаться навсегда, потому что внутри цикла ничего не изменится, ни x, ни Dis.Cells(x, 9).Value.

Думаю, вам нужно снова подумать о логике подпрограммы. Может быть, замена этого цикла на простой тест IF.

Answer 3

Do Loop не выйдет до Dis.Cells(x, 9).Value > 1. Внутри Do Loop вы меняете значения в Dis.Cells(x, 8). Если Dis.Range("I3:I600") не имеет в нем формул или если кто-либо из ячеек в Dis.Cells(x, 9).Value never exceed1 then the Do Loop` никогда не выйдет.

Do While Dis.Cells(x, 9).Value > 1 
    'IF same amount, get row number to get corresponding date, reference that date 
    For y = 3 To 600 

    Next y 
Loop 

Вы должны также отключить ScreenUpdating в то время как код работает. Если вам не нужны какие-либо формулы для пересчета, тогда установите Calculation на xlCalculationManual.

Application.ScreenUpdating = False 
Application.Calculation = xlCalculationManual 

Application.Calculation = xlCalculationManual 
Application.ScreenUpdating = False 

Почему вы используете Range.Copy?

Cheque.Cells(y, 2).Copy Destination:=Dis.Cells(x, 8) 

Прямое назначение гораздо более эффективна

Dis.Cells(x, 8) = Cheque.Cells(y, 2) 

Если нет никакой формулы, что вам нужно пересчитывать затем использовать массив вместо этого должен сократить вам время выполнения до менее 1 секунды.