程序没有响应-excel vba for循环

如果两张纸上的两个string匹配，我试图每次都按月计算总和

现在我没有看到任何地方在无限循环中，但是这个程序在一段时间后还没有响应，我最终必须closuresexcel。 任务pipe理器，因为即使Break指令不起作用。

这是一个相当简单的程序，但我不知道如何使它比这个更短请指教。

 Option Explicit Sub SumByMon() Application.ScreenUpdating = False Dim wk As Worksheet, wt As Worksheet Dim Astr As String, Bstr As String Dim i, j, FinalRow, FinalRowG As Long Dim sm As Double, Jsum As Double, Fsum As Double, Msum As Double, Asum As Double, Masum As Double, Jusum As Double, Julsum As Double, Ausum As Double, Ssum As Double, Osum As Double, Nsum As Double, Dsum As Double Dim Dt Dim LMon As Integer Set wk = Sheets("BR Mailing List_12-4-15 (3)") Set wt = Sheets("Total By Month") FinalRowG = wk.Range("N900000").End(xlUp).Row FinalRow = wt.Range("A900000").End(xlUp).Row For i = 2 To FinalRow Jsum = 0 Fsum = 0 Msum = 0 Asum = 0 Masum = 0 Jusum = 0 Julsum = 0 Ausum = 0 Ssum = 0 Osum = 0 Nsum = 0 Dsum = 0 Astr = Trim(wt.Range("A" & i)) For j = 2 To FinalRowG Bstr = Trim(wk.Range("N" & j)) If Astr = Bstr Then Dt = wk.Range("T" & j).Value LMon = Month(Dt) Select Case LMon Case 1 sm = wk.Range("S" & j).Value Jsum = Jsum + sm Case 2 sm = wk.Range("S" & j).Value Fsum = Fsum + sm Case 3 sm = wk.Range("S" & j).Value Msum = Msum + sm Case 4 sm = wk.Range("S" & j).Value Asum = Asum + sm Case 5 sm = wk.Range("S" & j).Value Masum = Masum + sm Case 6 sm = wk.Range("S" & j).Value Jusum = Jusum + sm Case 7 sm = wk.Range("S" & j).Value Julsum = Julsum + sm Case 8 sm = wk.Range("S" & j).Value Ausum = Ausum + sm Case 9 sm = wk.Range("S" & j).Value Ssum = Ssum + sm Case 10 sm = wk.Range("S" & j).Value Osum = Osum + sm Case 11 sm = wk.Range("S" & j).Value Nsum = Nsum + sm Case 12 sm = wk.Range("S" & j).Value Dsum = Dsum + sm Case Else Debug.Print LMon End Select Else: End If Next j wt.Range("B" & i) = Jsum wt.Range("C" & i) = Fsum wt.Range("D" & i) = Msum wt.Range("E" & i) = Asum wt.Range("F" & i) = Masum wt.Range("G" & i) = Jusum wt.Range("H" & i) = Julsum wt.Range("I" & i) = Ausum wt.Range("J" & i) = Ssum wt.Range("K" & i) = Osum wt.Range("L" & i) = Nsum wt.Range("M" & i) = Dsum Next i wt.Select Range("A1").Select Application.ScreenUpdating = True End Sub 

感谢您的所有努力，但即使通过使用数组方法，它也处于非响应状态，如果你想看看这里的文件 。

Answer 1

这个代码可能有问题的原因有很多：

1. 如果它是旧的或兼容模式版本的Excel，则此行可能会失败： wk.Range("N900000").End(xlUp).Row 。
2. 你正在写每个单元格，这是非常耗时的。 如果Sheet3中有很多行，那么你的代码可能会被locking，因为它需要很长时间才能写入
3. 你的声明已经放弃了对types的控制，因为所有'untyped'声明都是Variants 。 这使得debugging非常困难。 在你的评论中，你问“这是否有必要？”。 答案：不重要，但它会将您的debugging任务增加一个数量级，并且代码可能以您不期望的方式工作。 事实上，一个实际的答案是“是的，这是非常必要的”。
4. 没有检查单元格值和types。 如果单元格为空或不是date，则代码将仍然运行。如果所有variables均为Variants ，则在运行Month(dt)时，代码将不正确地聚合。
5. 使用.Text属性可能会导致问题。 例如，如果date列过于狭窄，并且单元格中有####，那么这将是.Text值（如果variables是“未声明的” Variant ，则再次超出了控制范围，更好的方法是Cstr(cell.Value)或Cstr(cell.Value2) 。
6. 你的代码是非常低效的，因为它循环遍历Sheet1中的相同数据。 更好的办法是只加载一次集合，其中的键是您正在testing的string值。 我在下面的例子中没有这样做，因为我有点时间不够，但是你应该考虑这样做。 如果Sheet1有很多行，那么你的代码真的会很慢。

另一点是，将数组写入Worksheet而不是一次一个单元格要快得多。 就你而言，月份聚合非常适合数组。 所以你可以通过使用一个优化和缩短你的代码。 下面的代码处理上面的几点，并使用一个数组作为例子。

您对Noam Hacker提出的Debug.Printbuild议似乎也不太清楚。 这是一个很好的build议，所以我在这个代码中给了你几个例子：

 Public Sub SumByMonWithArray() Dim startRowA As Long, startRowB As Long Dim finalRowA As Long, finalRowB As Long Dim strA As String, strB As String Dim m() As Variant Dim dt As Variant Dim r As Long, c As Long Dim i As Long, j As Long 'Define the start and end rows of each sheet startRowA = 2 startRowB = 2 finalRowA = Sheet3.Cells(Sheet3.Rows.Count, "A").End(xlUp).Row finalRowB = Sheet1.Cells(Sheet1.Rows.Count, "N").End(xlUp).Row 'Dimension your array r = finalRowA - startRowA + 1 If r < 1 Then Exit Sub 'exit if there's no data ReDim m(1 To r, 1 To 12) For i = startRowA To finalRowA Debug.Print "In loop i=" & CStr(i) 'shows progress (delete after testing) strA = Trim(CStr(Sheet3.Cells(i, "A").Value2)) 'If test value isn't blank run the comparison If strA <> "" Then r = i - startRowA + 1 For j = startRowB To finalRowB Debug.Print "In subloop i=" & CStr(i) & ", j=" & CStr(j) 'shows progress (delete after testing) strB = Trim(CStr(Sheet1.Cells(j, "N").Value2)) 'If there's a match aggregate the month array If strB <> "" And strA = strB Then 'Populate a Variant with cell value and check it's a date dt = Sheet1.Cells(j, "T").Value If IsDate(dt) Then c = Month(dt) 'Gets the column index of the array m(r, c) = m(r, c) + CDbl(Sheet1.Cells(j, "S").Value2) End If End If Next End If Next 'Write the aggregate array to Sheet 3 With Sheet3 .Cells(startRowA, "B").Resize(UBound(m, 1), UBound(m, 2)).Value = m .Activate .Range("A1").Select End With Application.ScreenUpdating = True End Sub 

Answer 2

考虑Sheet1这个模型数据：

首先在列T（销售date？）的右侧添加一列，公式=MONTH(T2)用于单元格U2 。

将“每月”标签添加/更改为整数（样本中的B1：M1）。

然后创builddynamic命名范围：

• SalesItemCol公式=OFFSET(Sheet1!$N$1,1,0,COUNTA(Sheet1!$N:$N)-1,1)
• SalesQtyCol公式=OFFSET(Sheet1!$N$1,1,5,COUNTA(Sheet1!$N:$N)-1,1)
• SalesMonthCol公式=OFFSET(Sheet1!$N$1,1,7,COUNTA(Sheet1!$N:$N)-1,1)

最后在B2上，使用公式=SUMIFS(SalesQtyCol,SalesItemCol,$A2,SalesMonthCol,B$1)然后自动填充剩下的。

或者，您可以创buildmacros来执行上述操作