将数据复制到列B中的空白单元格，直到列A中最后使用的范围

我有这样的数据

我想让它看起来像这样

我写的代码遍历A列中的所有值，并将值抵消到B列

Sub FindString() Dim A As Range, r As Range Set A = Intersect(ActiveSheet.UsedRange, Range("A:A")) For Each r In A If IsNumeric(Left(r, 6)) Then r.Copy r.Offset(0, 1) End If Next r End Sub 

如果前6个数值是数字，此代码将从A列复制数据到B，但我想帮助将数据复制到B列中的所有空白单元格，直到findA列中的匹配值

Answer 1

 Sub FindString() Dim A As Range, r As Range, last As Range Set A = Intersect(ActiveSheet.UsedRange, Range("A:A")) For Each r In A If IsNumeric(Left(r, 6)) Then Set last = r If Not last Is Nothing Then last.Copy r.Offset(0, 1) Next r End Sub 

ps：注意使用UsedRange时的问题。 考虑在这个站点中寻找find列中最后一个非空单元格的最佳方法。

编辑

使用公式的非VBA方法（可能会更快）

 At cell B4: `=A4` At cell B5: `=IF(ISNUMBER(VALUE(LEFT(A5, 6))), A5, B4)` Now copy B5, select the whole column B until last cell and paste. 

Answer 2

这是一个快速的方法（巧合类似于ASH的手动方法）

 Sub Demo() Dim r As Range With ActiveSheet Set r = .Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)) End With r.Offset(0, 1).Formula = "=IF(ISNUMBER(VALUE(LEFT(A4,6))),A4,B3)" r.Offset(0, 1) = r.Offset(0, 1).Value End Sub 

在我的系统上运行100,000行