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

Question

我有看起来像这样的数据

我想让它看起来像这样

我编写的代码遍历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列中的所有空白单元格，直到在A列中找到匹配的值为止

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时要注意问题。 考虑在此站点上搜索找到列中最后一个非空单元格的最佳方法。

编辑

使用公式的非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

在我的系统上以<1s的速度运行100,000行