我希望我知道在循环遍历范围之前使用数组，这样可以保存时间，特别是如果你正在处理更大的文件，你的文件看起来像是可以的。所以这就是为什么我试图让新手从一开始就了解他们和他们的速度：

Sub fillRange()

    Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("test")
    Dim lRow As Long: lRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
    Dim SrchRng As Range, i As Long, arr(), arrP()
    Dim currentAcc As Long, rCount As Long
    
    Set SrchRng = ws.Range("A2:C" & lRow) 'headerrow can remain as is
    arr = SrchRng.Value
    ReDim arrP(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'UBound(arr,1) = how many "rows" in the array, UBound(arr,2) = how many "columns"
    
    For i = 1 To UBound(arr, 1) ' it is slower to iterate over cells/ranges than to work with arrays
        If arr(i, 3) Like "4*" Then
            currentAcc = arr(i, 3) 'arr(i,3) means the i+1'th (header including) row the third column
        End If
        If IsDate(arr(i, 2)) Then 'we want to skip the "Date Code" line as well in your example
            rCount = rCount + 1 'we use rCount since we want to skip the unnecessary rows
            arrP(rCount, 1) = currentAcc
            arrP(rCount, 2) = arr(i, 2)
            arrP(rCount, 3) = arr(i, 3)
        End If
    Next i
    
    ws.Range("A2:C" & rCount + 1).Value = arrP
    ws.Range("A" & rCount + 1 & ":C" & lRow).Offset(1, 0).Delete 'delete what's left
End Sub

我从这个设置开始：

数组使得VBE不需要与Excel进行太多的交互（这通常会减慢它的速度）

编辑：

这将容纳更多列：

Sub fillRange()

    Dim ws As Worksheet: Set ws = ActiveWorkbook.Sheets("test")
    Dim lRow As Long: lRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
    Dim SrchRng As Range, i As Long, arr(), arrP()
    Dim currentAcc As Long, rCount As Long
    Dim lCol As Long: lCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
    
    Set SrchRng = ws.Range(ws.Cells(2, 1), ws.Cells(lRow, lCol)) 'headerrow can remain as is
    arr = SrchRng.Value
    ReDim arrP(1 To UBound(arr, 1), 1 To UBound(arr, 2)) 'UBound(arr,1) = how many "rows" in the array, UBound(arr,2) = how many "columns"
    
    Dim j As Long
    For i = 1 To UBound(arr, 1) ' it is slower to iterate over cells/ranges than to work with arrays
        If arr(i, 3) Like "4*" Then
            currentAcc = arr(i, 3) 'arr(i,3) means the i+1'th (header including) row the third column
        End If
        If IsDate(arr(i, 2)) Then 'we want to skip the "Date Code" line as well in your example
            rCount = rCount + 1 'we use rCount since we want to skip the unnecessary rows
            arrP(rCount, 1) = currentAcc
            For j = 2 To lCol
                arrP(rCount, j) = arr(i, j)
            Next j
        End If
    Next i
    
    With ws
        .Range(.Cells(2, 1), .Cells(rCount + 1, lCol)).Value = arrP
        .Range(.Cells(rCount + 1, 1), .Cells(lRow, lCol)).Offset(1, 0).Delete 'delete what's left
    End With
End Sub

它看起来是这样的：

如果你有任何问题，请随时提问：）

不确定您的实际数据是否具有样本数据中所见的固定模式。无论如何，如果是，那么另一种方法是过滤包含“account num”的列。请注意，先生。Notus_Panda的代码要快得多。
下入接头前：（请忽略填充颜色）

代码假设数据的修复模式如下：
每组将附上相同的帐号，（样本数据：黄色、橙子和蓝色）。
永远会有两个相同的账号，永远不会有两个以上相同的账号，永远不会只有一个账号。列A中的最后一行数据总是与列B中的最后一行数据相同。
如示例数据所示，B2和B9具有相同的值，即41008（黄色），
B10和B18的值相同，都是42008（橙子），蓝色的那个也有两个“51001”

Sub test()
Dim rg As Range, rgAcc As Range, i As Integer
Dim c1 as Range, c2 as Range

Application.ScreenUpdating = False

With Sheet1
    .Columns("A:A").Insert Shift:=xlToRight
    .Range("A1").Value = "Account num"
    Set rg = .Range("B1", .Range("C" & Rows.Count).End(xlUp))
End With

rg.AutoFilter Field:=1, Criteria1:="=account num"
Set rgAcc = rg(1, 2).Resize(rg.Rows.Count - 1, 1).Offset(1, 0).SpecialCells(xlVisible)

    i = 1
    For Each cell In rgAcc
        If i = 1 Then Set c1 = cell Else Set c2 = cell
        i = i + 1
        If i = 3 Then Range(c1.Offset(1, -2), c2.Offset(-1, -2)).Value = cell.Value: i = 1
    Next

    With rg
        .AutoFilter Field:=1, Criteria1:=Array("account num", "date"), Operator:=xlFilterValues
        .Offset(1, 0).SpecialCells(xlVisible).EntireRow.Delete
        .AutoFilter Field:=1
    End With

Application.ScreenUpdating = True
End Sub

首先，sub做与您相同的事情，即在列A中插入一列“Account Num”标题。
然后，它创建从单元格B1到列C的rg变量，无论是带有数据的lastrow，用“account num”过滤rg，然后将rgAcc设置为列CODE的可见单元格的范围。
然后循环到rgAcc中的每个单元格，创建循环单元格的两个范围变量，如果i = 1，则为c1，如果i=2，则为c2。到i值为3时，它将i重置为1，并使用循环单元格值填充列A（该行位于c1行和c2行之间）。
最后用“account num”和“date”两个条件过滤B列，然后删除该行。
如果B列“帐户编号”和“日期”文本不固定，则无法运行子程序。例如，在一个单元格中，值是“account num”，另一个单元格值是“account number”。..一个单元格值是“date”，另一个单元格值是“date blablabla”。