Question

I'm writing a macro that compares a general list of dates (Sheet1) with a list of "business dates" where the office is open(COF). So if a date on the general list is not on the business dates list, my macro should try to find the closest business date to the date on the general list and assign it to the column to the right. The contents in the cells are formatted identically as dates. Unfortunately, Excel completely freezes every time I try to run the macro and I have to force quit, without an error message or anything.

Sub BusinessDate()
'Finds the closest business date to a lease date, solving for weekends
Dim businessday As Boolean
Dim shift As Integer

For Each Cell1 In Worksheets("Sheet1").Range("B2:B10000")
'Change 10000 to maximum number of rows if > 10000 rows
    businessday = False

    For Each Cell2 In Worksheets("COF").Range("A2:A10000")

        If Cell1.Value = Cell2.Value Then
            businessday = True
            Cell1.Offset(0, 1).Value = Cell1.Value
        End If

    Next Cell2
    shift = 1
    Do While businessday = False And shift < 6

        For Each Cell2 In Worksheets("COF").Range("A2:A10000")

            If Cell1.Value + shift = Cell2.Value Then
                businessday = True
                Cell1.Offset(0, 1).Value = Cell1.Value + shift
                Exit Do
            End If

        Next Cell2

        For Each Cell2 In Worksheets("COF").Range("A2:A10000")

            If Cell1.Value - shift = Cell2.Value Then
                businessday = True
                Cell1.Offset(0, 1).Value = Cell1.Value - shift
            End If

        Next Cell2
        shift = shift + 1
        Loop
    Next Cell1
End Sub

Did I write something wrong in my code?

Thank you!

Answer 1

事实证明，循环太大了，Excel并没有崩溃，而是花了很长时间才能完成宏。您可以通过使用变量表示每张工作表中的最后一行数据来缩短过程，如下所示：

Dim lastrowsheet1 As Integer   
lastrowsheet1 = Worksheets("Sheet1").Range("B1").End(xlDown).row        
For Each Cell1 In Worksheets("Sheet1").Range("B2:B" & lastrowsheet1)

还包括一个Exit For语句，以避免在找到匹配项后循环遍历单元格的其余部分，从而大大减少了宏完成所需的时间：

If Cell1.Value = Cell2.Value Then 
    businessday = True 
    Cell1.Offset(0, 1).Value = Cell1.Value 
    Exit For 
End If

此外，如果您知道用户在宏运行时不会使用Excel，则DoEvents会很有帮助

Macro keeps crashing Excel

1 个答案: