将数据复制到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

p.s：请注意使用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

在我的系统上以＆lt; 1s运行100,000行