首先，我为张贴这么大一部分vba而道歉，但这只是一个片段！我已经在数据的测试部分使用了我的宏，它工作正常。但是，在数据的完整范围内使用它（3447行x 5400列）时，它已运行3天而无法正常工作。然后我逐行运行它，看起来这部分导致问题。它运行的是Excel 2013 64位，目前使用7.5GB的内存，但我相信这会增加到宏的后续容量~16GB。
如何改进任何代码的任何建议都将非常受欢迎。
Application.Calculation = xlManual
For j = 0 To NumberDays - 1
For h = 5 To NumberLinks + 4 'Columns
For i = 5 + j * 14 To 16 + j * 14 'Rows
If Cells(i, h) = 0 Then 'Found a 0 to be filled in
'Stop
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 Then _
'If hours starting 6 to 9 are zero use profile
Range(Cells(i, h), Cells(i + 2, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
Cells(i + 1, h) = Worksheets("Zeroes").Cells(MedianLook + 1, h)
Cells(i + 2, h) = Worksheets("Zeroes").Cells(MedianLook + 2, h)
End If 'If3
Next MedianLook
GoTo ProfileWasRequired:
End If
If i = 14 + j * 14 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 Then _
'If hours starting 16 to 19 are zero use profile
Range(Cells(i, h), Cells(i + 2, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
Cells(i + 1, h) = Worksheets("Zeroes").Cells(MedianLook + 1, h)
Cells(i + 2, h) = Worksheets("Zeroes").Cells(MedianLook + 2, h)
End If
Next MedianLook
GoTo ProfileWasRequired:
End If
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) <> 0 Then _
'Hours 6 to 8 are zero, fill hours 7 and 8 with hour 9 data
Cells(i + 1, h) = Cells(i + 2, h)
Cells(i, h) = Cells(i + 2, h)
End If
If i = 5 + j * 14 And Cells(i - 1, h) = 0 And Cells(i + 1, h) <> 0 Then _
'Hours 6 and 7 are zero, fill hour 7 with hour 8
Cells(i, h) = Cells(i + 1, h)
End If
If i = 15 + j * 14 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i - 1, h) <> 0 Then _
'If hours starting 17 to 19 are zero, fill hours 17 and 18 with hour 16 data
Cells(i + 1, h) = Cells(i - 1, h)
Cells(i, h) = Cells(i - 1, h)
End If
If i = 16 + j * 14 And Cells(i + 1, h) = 0 And Cells(i - 1, h) <> 0 Then _
'If hours 18 to 19 are zero, fill hour 18 with hour 17 data
Cells(i, h) = Cells(i - 1, h)
End If
If Cells(i - 1, h) <> 0 And Cells(i + 1, h) <> 0 Then _
'One hour is zero, fill with average of preceding and subsequent hours' data
Cells(i, h) = (Cells(i - 1, h) + Cells(i + 1, h)) / 2
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) = 0 Then _
'Error if 5 sequential hours are zero
Range(Cells(i, h), Cells(i + 4, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
LinestoFillDown = 1
Do While Cells(i + LinestoFillDown, 4) < 19 'only do up to hour starting 18
Cells(i + LinestoFillDown, h) = Worksheets("Zeroes").Cells(MedianLook + LinestoFillDown, h)
LinestoFillDown = LinestoFillDown + 1
Loop
End If
Next MedianLook
GoTo ProfileWasRequired:
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) = 0 And Cells(i + 4, h) = 0 Then _
'Error if 6 sequential hours are zero
Range(Cells(i, h), Cells(i + 5, h)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 255
.TintAndShade = 0
.PatternTintAndShade = 0
End With
MonthSearch = Cells(i, 2)
DayTypeSearch = Cells(i, 3)
HourSearch = Cells(i, 4)
LinkSearch = Cells(1, h)
For MedianLook = 4000 To 4335
If Worksheets("Zeroes").Cells(MedianLook, 2) = MonthSearch _
And Worksheets("Zeroes").Cells(MedianLook, 3) = DayTypeSearch _
And Worksheets("Zeroes").Cells(MedianLook, 4) = HourSearch Then
Cells(i, h) = Worksheets("Zeroes").Cells(MedianLook, h)
LinestoFillDown = 1
Do While Cells(i + LinestoFillDown, 4) < 19 'only do up to hour starting 18
Cells(i + LinestoFillDown, h) = Worksheets("Zeroes").Cells(MedianLook + LinestoFillDown, h)
'
LinestoFillDown = LinestoFillDown + 1
Loop
End If
Next MedianLook
GoTo Error:
End If
If i < 14 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) = 0 And Cells(i + 4, h) <> 0 Then _
'if four sequential hour are zero fill first and last from preceding and subsequent hours and middle two by average of those
Cells(i, h) = Cells(i - 1, h)
Cells(i + 3, h) = Cells(i + 4, h)
Cells(i + 1, h) = (Cells(i - 1, h) + Cells(i + 4, h)) / 2
Cells(i + 2, h) = (Cells(i - 1, h) + Cells(i + 4, h)) / 2
End If
If i < 15 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) = 0 And Cells(i + 3, h) <> 0 Then _
'If three sequential hours are zero fill first and last from preceding and subsequent hours and middle one average of those
Cells(i, h) = Cells(i - 1, h)
Cells(i + 2, h) = Cells(i + 3, h)
Cells(i + 1, h) = (Cells(i - 1, h) + Cells(i + 3, h)) / 2
End If
If i < 16 + j * 14 And Cells(i - 1, h) <> 0 And Cells(i + 1, h) = 0 And Cells(i + 2, h) <> 0 Then _
'Except for last hour, fill two zero cells from preceding and subsequent ones
Cells(i, h) = Cells(i - 1, h)
Cells(i + 1, h) = Cells(i + 2, h)
End If
End If '(If 1)
ProfileWasRequired:
Next i
Next h
Next j
Application.Calculation = xlAutomatic
答案 0 :(得分：3)
我建议您在任何时候迭代它们之前存储范围值。无论何时您必须访问屏幕上可以看到的值，它都会变慢。但是，您无法通过这种方式更新边框或背景。
以下是使用上面“细胞”的示例。在我的机器上，需要大约2秒钟才能循环通过65535个单元格。
Sub UsingCells()
Dim tmr As Single
tmr = Timer
Dim i As Long
For i = 1 To 65535
Cells(i, 1) = Cells(i, 1)
Next i
Debug.Print Timer - tmr
End Sub
以下是使用存储在内存中的范围值后的示例。在我的机器上，它需要大约30毫秒才能循环通过相同的65535个单元格。
Sub UsingStoredValues()
Dim tmr As Single
tmr = Timer
Dim vals As Variant
vals = Range("A1:A65535").Value2
Dim i As Long
For i = 1 To 65535
vals(i, 1) = vals(i, 1)
Next i
Range("A1:A65535").Value2 = vals
Debug.Print Timer - tmr
End Sub