VBA：根据单元格范围和间隔填充“时间”列

Question

我有一个 Excel 工作表，我需要在时间列中填充一系列单元格，该范围是用户输入，时间间隔也是如此。

我可以使用 For 循环来实现这一点，但可能有大约 50000 多个单元格，并且写入每个单元格需要很长时间。

我认为有一种方法可以在 VBA 中实现这一点，方法是创建一个范围大小的数组，填充该数组，然后将该数组复制到工作表中？我对一般的 C 风格编程相当熟悉，但对 VBA 不太熟悉。

如果我的单元格排列在 A1 包含开始单元格（例如 1）和 B1 包含结束单元格（例如 100）的位置，A2 包含开始时间 (00:00:00) 而 B2 包含时间间隔 ( 00:05:00) 我将如何使用 VBA 填充单元格 D1:D100，如 00:00:00、00:05:00、00:10:00... 等。

（实际上，单元格引用是跨工作表和更大范围的，但我可以稍后对其进行排序）。

提前致谢。

Answer 1

这里有一些不使用数组但速度非常快的 VBA。它使用公式，然后将它们粘贴为值。 50,000大约需要一秒钟：

Sub FillColumn()
Dim ws As Excel.Worksheet
Dim FillRange As Excel.Range
Dim FirstValue As Double
Dim ValueIncrement As Double
Dim FirstCell As Long
Dim LastCell As Long

Application.ScreenUpdating = False
Set ws = ActiveSheet
With ws
    FirstCell = .Range("A1")
    LastCell = .Range("B1")
    FirstValue = .Range("A2")
    ValueIncrement = .Range("B2")
End With
Set FillRange = ws.Range("D" & FirstCell).Resize((LastCell - FirstCell) + 1, 1)
With FillRange
    .Cells(1) = FirstValue
    .Offset(1, 0).Resize(.Rows.Count - 1, 1).Formula = "=R[-1]C+" & ValueIncrement
    .Value = .Value
    .NumberFormat = "hh:mm:ss"
End With
Application.ScreenUpdating = True
End Sub

编辑：解释这一行.Offset(1, 0).Resize(.Rows.Count - 1, 1).Formula = "=R[-1]C+" & ValueIncrement

Offset(1,0) 指的是比 FillRange 低 1 行的范围，例如D2:D50001

.Resize(.Rows.Count - 1, 1) 取前一个并将其缩短一行，例如 D2:D50000

.Formula = "=R[-1]C+" & ValueIncrement 将公式应用于该范围。该公式只是说将 ValueIncrement 添加到上面的单元格中。如果我在这一行之后停止代码，公式看起来像=D1+0.0000578703703703704。通过遵循此most excellent tip by Dick Kusleika，我得到了代码中使用的 R1C1 样式公式。

这是一个数组版本。 50,000似乎更快一些。但是，由于Application.Transpose 的限制，它只适用于65536 个元素。我不确定是否有更好的方法来填充数组，即不使用循环：

Sub FillColumn2()
Dim ws As Excel.Worksheet
Dim FillRange As Excel.Range
Dim FirstValue As Double
Dim ValueIncrement As Double
Dim FirstCell As Long
Dim LastCell As Long
Dim arr As Variant
Dim i As Long

Application.ScreenUpdating = False
Set ws = ActiveSheet
With ws
    FirstCell = .Range("A1")
    LastCell = .Range("B1")
    FirstValue = .Range("A2")
    ValueIncrement = .Range("B2")
End With
ReDim arr(FirstCell To LastCell)
arr(1) = FirstValue
For i = FirstCell + 1 To LastCell
    arr(i) = arr(i - 1) + ValueIncrement
Next i
Set FillRange = ws.Range("D" & FirstCell).Resize((LastCell - FirstCell) + 1, 1)
FillRange = Application.Transpose(arr)
Application.ScreenUpdating = True
End Sub