Why does my VBA code keep hanging? - vba

Question

I attached two links to a flowchart of how the VBA code should go about, and a screenshot of my two sheets.
Basically, I have two sheets - "Disbursements" & "Cheque Info". On the Disbursements' sheet, I need to consider only the rows with count > 1 (column I). For example, I won't consider row 8 of column I, but will consider row 12. Every row that has a count of > 1 should have a value on row H by the end of the run.
After considering which row has a count >1, we check if the corresponding amount (column F) is equal to Cheque Info's column E. Then if for example, for row 12 of disbursements, 1,384.35 is equal to row 9 of Cheque Info. We must get the difference of these dates then store it to a variable "Current". But there are many "1,384.35" that we must get the minimum difference for the dates, thus a need for a loop.
Again, I need to do loops for each row that has a count of >1 on disbursements' column I, so that I will get the date on Cheque Info (with the same amount) that has a minimum gap from the date on Disbursements sheet. For example, the date that has the least gap for 1/18/2016 (for the amount 1,384.35) is 1/4/2016.
Here is my current code:
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

Your code hangs because you dont have any check s for null/vbnullstring or 0 values. i.e.:
IF Dis.Cells(x,6).Value <> vbNullString OR Dis.Cells(x,6).Value <> 0 Then....
reason this is needed is to keep excle from looping through each cell till out of memory...

Answer 2

Your Do Whileloop is an infinite loop. Once it catches a cell such that Dis.Cells(x, 9).Value > 1 it will loop forever, because inside the loop, nothing will change, neither x nor Dis.Cells(x, 9).Value.
I think you have to think again the logic of the subroutine. Maybe replacing that loop with a simple IF test would do.

Answer 3

The Do Loop will not exit until Dis.Cells(x, 9).Value > 1. Inside the Do Loop you change values in Dis.Cells(x, 8). If Dis.Range("I3:I600") does not have formulas in it or if anyone of the cells in Dis.Cells(x, 9).Value never exceed1 then theDo Loop` will never exit.
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
You should also turn off ScreenUpdating while the code is running. If you don't need any formulas to recalculate then set Calculation to xlCalculationManual.
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Why are you using Range.Copy?
Cheque.Cells(y, 2).Copy Destination:=Dis.Cells(x, 8)
A direct assignment is much more effecient
Dis.Cells(x, 8) = Cheque.Cells(y, 2)
If there are no formula that you need to recalculate then using an array instead should cut you execution time to under 1 second.