请教用VB来下拉增加序号

q99999

  请教一下各位，假设B2到B25行，当遇到有内容时自动在内容后面追加序号并下拉，遇到下一个内容后重新01开始，请问这样用VB是怎么写的呢？感谢！

hasyh2008

Sub 序号()
  Dim Rc%, Arr(), K%
  Arr = Sheet1.Range("A1").CurrentRegion

  For Rc = 2 To UBound(Arr)
    If Arr(Rc, 2) <> "" Then
       K = 1
       Arr(Rc, 3) = Arr(Rc, 2) & "01"
    Else
      K = K + 1
      Arr(Rc, 3) = VBA.Left(Arr(Rc - 1, 3), VBA.Len(Arr(Rc - 1, 3)) - 2) & Application.WorksheetFunction.Text(K, "00")
    End If
  Next Rc
  Sheet1.Range("A1").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub

q99999

hasyh2008 发表于 2022-4-27 17:12
Sub 序号()
  Dim Rc%, Arr(), K%
  Arr = Sheet1.Range("A1").CurrentRegion

额，老师您好，这个理解刚好反了，我是想当A2只有一个内容时，后面的空格单元会向下下拉，遇到有一个单元格有内容又重新开始，是这个意思，并不是单独在内容上增加序号

釜底抽薪

学习

hasyh2008

Sub 序号()
  Dim Rc%, Arr(), K%, Str$
  Arr = Sheet1.Range("A1").CurrentRegion
  For Rc = 2 To UBound(Arr)
    If Arr(Rc, 2) <> "" Then
      K = 1
      Str = Arr(Rc, 2)
      Arr(Rc, 2) = Str & "01"
    Else
      K = K + 1
      Arr(Rc, 2) = Str & Application.WorksheetFunction.Text(K, "00")
    End If
  Next Rc
  Sheet1.Range("A1").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub