为什么我的VBA代码会挂起？

Question

我附上了两个指向VBA代码应该如何运行的流程图的链接，以及我的两张表的截图。

基本上，我有两张纸 - “支出”＆amp; “检查信息”。在付款表上，我只需要考虑带有计数的行＆gt; 1（第一栏）。例如，我不会考虑第I列的第8行，但会考虑第12行。每行的计数都是＆gt;在运行结束时，1应该在行H上有一个值。 在考虑哪一行具有> 1的计数之后，我们检查相应的数量（列F）是否等于检查信息的列E.然后，例如，对于支付的第12行，1,384.35等于检查信息的第9行。我们必须得到这些日期的差异，然后将其存储到变量“当前”。但是有许多“1,384.35”我们必须得到日期的最小差异，因此需要一个循环。

同样，我需要为支付列I上的计数> 1的每一行执行循环，这样我就可以在Check Info（具有相同数量）上获得与日期差距最小的日期付款表上的日期。例如，2016年1月18日（金额为1,384.35）的差距最小的日期是2016年1月4日。

这是我目前的代码：

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

您的代码挂起，因为您没有检查null / 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秒以下。