代码在经历超过 46 次迭代时返回运行时错误

Question

我写了一些代码，在开始日期和结束日期之间分配月费。当我在 46 次迭代中执行它时，它工作得很好(这意味着计算了 48 个不同的订阅)。但是，在迭代编号 46 之后，它会返回运行时错误。 有没有人知道如何提高代码效率或如何延长Excel中的"运行时间段"？如果代码运行 1 分钟仍然没问题。

这是我的代码：

Sub CalcualteDistribution()
Dim c As Range
For Each c In Worksheets("Table2").Range("C2", Range("C2").End(xlDown))
If Not IsEmpty(c.Value) Then
Call MonthlyDistribution(c)
End If
Next c
End Sub
Sub MonthlyDistribution(c As Range)
Dim FirstDate As Date
Dim LastDate As Date
Dim NextDate As Date
'Amount for months with 30 days
Dim amount30 As Double
'Amount for months with 31 days
Dim amount31 As Double
'Amount for february
Dim amountFeb As Double
Dim price As Double
Dim numberDays As Integer
Dim count As Range
Dim jan, feb, mar, apr, may, jun, jul, aug, sep, oct, nov, dec As Double
jan = 0
feb = 0
mar = 0
apr = 0
may = 0
jun = 0
jul = 0
aug = 0
sep = 0
oct = 0
nov = 0
dec = 0
Set count = c
FirstDate = count.Value
LastDate = count.Offset(0, 13).Value
NextDate = FirstDate
price = count.Offset(0, 14).Value
numberDays = count.Offset(0, 17).Value
amount30 = price / 30
amount31 = price / 31
amountFeb = price / 28
amountFebSchalltjahr = price / 29

While NextDate <= LastDate
If Month(NextDate) = 1 Then
jan = jan + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 2 Then
feb = feb + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 3 Then
mar = mar + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 4 Then
apr = apr + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 5 Then
may = may + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 6 Then
jun = jun + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 7 Then
jul = jul + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 8 Then
aug = aug + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 9 Then
sep = sep + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 10 Then
oct = oct + 1
NextDate = NextDate + 1
ElseIf Month(NextDate) = 11 Then
nov = nov + 1
NextDate = NextDate + 1
Else
dec = dec + 1
NextDate = NextDate + 1
End If
Wend
count.Offset(0, 1).Value = jan * amount31
count.Offset(0, 2).Value = feb * amountFeb
count.Offset(0, 3).Value = mar * amount31
count.Offset(0, 4).Value = apr * amount30
count.Offset(0, 5).Value = may * amount31
count.Offset(0, 6).Value = jun * amount30
count.Offset(0, 7).Value = jul * amount31
count.Offset(0, 8).Value = aug * amount31
count.Offset(0, 9).Value = sep * amount30
count.Offset(0, 10).Value = oct * amount31
count.Offset(0, 11).Value = nov * amount30
count.Offset(0, 12).Value = dec * amount31
End Sub

Answer 1

注意：这几乎肯定不会解决运行时错误问题的根源。但是，它将显着提高代码的质量，从而提高效率。所以这是对"有没有人知道我如何使代码更有效率......">

Sub CalcualteDistribution()
Dim cell As Range
With ThisWorkbook.Worksheets("Table2")
For Each cell In .Range("C2").Resize(.Range("C2").End(xlDown).Row)
If Not IsEmpty(cell.Value) Then
MonthlyDistribution cell
End If
Next cell
End With
End Sub
Sub MonthlyDistribution(ByVal InputCell As Range)
' Default value of `Double` is 0, so no need to explicitly set the value to 0.
Dim Months(1 To 12) As Double
Dim FirstDate As Date
FirstDate = InputCell.Value
Dim LastDate As Date
LastDate = InputCell.Offset(0, 13).Value
Dim price As Double
price = InputCell.Offset(0, 14).Value
' Use Long over Integer
'Dim numberDays As Integer
Dim numberDays As Long
numberDays = InputCell.Offset(0, 17).Value
'Amount for months with 30 days
Dim amount30 As Double
amount30 = price / 30
'Amount for months with 31 days
Dim amount31 As Double
amount31 = price / 31
'Amount for february
Dim amountFeb As Double
amountFeb = price / 28
' Note that you dont actually use this anywhere
amountFebSchalltjahr = price / 29
Dim NextDate As Date
NextDate = FirstDate
While NextDate <= LastDate
Months(Month(NextDate)) = Months(Month(NextDate)) + 1
NextDate = NextDate + 1
Wend
Dim i As Long
For i = 1 To 12
Select Case i
Case 1, 3, 5, 7, 8, 10, 12
InputCell.Offset(0, i).Value = Months(i) * amount31
Case 4, 6, 9, 11
InputCell.Offset(0, i).Value = Months(i) * amount30
Case 2
InputCell.Offset(0, i).Value = Months(i) * amountFeb
End Select
Next
End Sub

我只做了一些调整，但理想情况下，这将使您的代码更易于阅读和维护。值得指出的第一件事是，我使您的变量更具描述性。我把c改成cell，把MonthlyDistribution的c改成InputCell。从那里，代码使用InputCell而不是创建指针的副本(没有必要)。我还删除了已弃用的Call。

使用参数调用子例程时，只需使用以下语法：SubName arg1, arg2, arg3....

当有返回(例如函数)时，您需要使用括号：Foo = FunctionName(arg1, arg2, arg3...)

我没有为每个月(jan、feb、mar等)创建一个月份变量，我只使用了一个Months数组。这使您的代码可预测。请注意，当您只是修改一个值时，不需要丑陋的if/else-if。当然，我不反对if陈述，但我很少使用超过一两个ElseIf。如果我发现自己这样做，我会使用Select Case或进一步抽象我的代码。

最后，在写回值时，我只需要一个Select Case在 30 天、31 天或 28 天的费率之间进行选择。理想情况下，最好编写一个处理确定一个月天数的函数(因为，尽管为闰年创建了一个变量，但你从不使用它)。不过，这超出了我的回答范围。

最终像这样重构代码应该更容易弄清楚发生了什么，并且也应该更容易维护代码。

现在，减少该错误的根源，我将首先检查以下行：

Worksheets("Table2").Range("C2", Range("C2").End(xlDown))因为这依赖于ActiveWorkbook和ActiveSheet(对于第二个范围调用)。要解决这些问题，请尝试以下操作：

With ThisWorkbook.Worksheets("Table2")
For Each cell In .Range("C2").Resize(.Range("C2").End(xlDown).Row)
If Not IsEmpty(cell.Value) Then
MonthlyDistribution cell
End If
Next cell
End With

请注意，现在工作表由ThisWorkbook(即运行代码的工作簿)限定，第二个Range引用由With ...子句限定。最后，我显式地将范围调整到最后一行(这也适用于.End(xlUp)。这些措施降低了这是问题根源的可能性。

这只会让您知道您的日期是问题的根源。坦率地说，我还没有处理过足够的日期来在那里刺痛它，但是如果您的日期导致问题，您要么有隐式日期转换(当无法解释时将值读取到Date变量中)，或者您正在尝试以不起作用的方式执行日期添加。在您的 OP 中没有其他细节，我会从这里猜测。

执行以下步骤来改进您的代码，看看您是否可以解决问题。如果没有，请更新您的答案并提供一些额外的详细信息，我们可以尽我们所能提供帮助。

Answer 2

这必须是 VBA 吗？ 这可以通过公式完成。 在"Table2"工作表中的单元格 D2 中，使用此公式，然后复制到 O 列并向下复制尽可能多的行：

=IF(AND($C2<DATE(YEAR($C2),COLUMN(A2)+1,1),$P2>=DATE(YEAR($C2),COLUMN(A2),1)),(MIN(EOMONTH(DATE(YEAR($C2),COLUMN(A2),1),0),$P2)-MAX(DATE(YEAR($C2),COLUMN(A2),1),$C2)+1)*($Q2/DAY(EOMONTH(DATE(YEAR($C2),COLUMN(A2),1),0))),"")

或者，如果它绝对必须是 VBA，那么这将对您有用：

Sub tgr()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Sheets("Table2")
With ws.Range("C2", ws.Cells(ws.Rows.Count, "C").End(xlUp)).Offset(, 1).Resize(, 12)
If .Row < 2 Then Exit Sub   'No data
.Formula = "=IF(AND($C2<=DATE(YEAR($C2),COLUMN(A2)+1,1),$P2>=DATE(YEAR($C2),COLUMN(A2),1)),(MIN(EOMONTH(DATE(YEAR($C2),COLUMN(A2),1),0),$P2)-MAX(DATE(YEAR($C2),COLUMN(A2),1),$C2)+1)*($Q2/DAY(EOMONTH(DATE(YEAR($C2),COLUMN(A2),1),0))),"""")"
.Value = .Value
End With
End Sub