Excel中用VBA，按顺序添加序号？

简单的说就是 点 大项，在A列非空，依次写A或B。。。C...D

小项 就是 数字 递增，根据前面的

A列先输入 A

Sub 大项()

Dim i

For i = Range("A65536").End(xlUp).Row To 1 Step -1

x = Asc(Cells(i, 1))

If (x >= 65 And x <= 90) Then

n = Range("A65536").End(xlUp).Row

Cells(n + 1, "A") = Chr(1 + x)

Exit Sub

End If

Next

End Sub

Sub 小项()

Dim n

n = Range("A65536").End(xlUp).Row

x = Asc(Cells(n, 1))

If (x >= 65 And x <= 90) Then

Cells(n + 1, "A") = 1

Else

Cells(n + 1, 1) = Cells(n, 1) + 1

End If

End Sub

Sub test()

Dim myRange As Range

Dim num as String, title as String

'Set ps = Selection.Bookmarks("\headinglevel").Range.Paragraphs

Set ps = ActiveDocument.Bookmarks("\headinglevel").Range.Paragraphs

For Each p In ps

Set myRange = p.Range

num = myRange.ListFormat.ListString

title = myRange.Text

MsgBox "编号：" &num &vbCrLf &"标题内容：" &title

Next p

'Set myRange = Selection.Bookmarks("\headinglevel").Range.Paragraphs(1).Range

'MsgBox "编号：" &myRange.ListFormat.ListString &vbCrLf &"标题内容：" &myRange.Text

End Sub

另外附上一段把标题(Heading)序号取出并附加在标题内容后面的代码：

Sub ReplaceHeadingContent()

Dim myRange As Word.Range

Dim num As String, content As String

'取得所有书签

Set ps = ActiveDocument.Bookmarks("\headinglevel").Range.Paragraphs

'对书签中每一个段落进行处理

For Each p In ps

Set myRange = p.Range

With myRange

'把Range结束范围往前移一个字符，目的是为了不包括换行符

.MoveEnd Unit:=wdWord, Count:=-1

'取出段落序号

num = Trim(.ListFormat.ListString)

'取出Heading的内容

content = Trim(.Text)

'如果段落序号不为空，则把段落序号取出附加的标题内容后面

If Trim(num) <>"" Then

If num = "1.1.1.1.1." Or num = "1.1.1.1.1" Then

MsgBox "到目标点了。"

End If

If Right(num, 1) = "." Then num = Left(num, Len(num) - 1) '不需段落序号最后面的“.”

.Text = content &"<" &num &">"

End If

'MsgBox "编号：" &num &vbCrLf &"标题内容：" &content

End With

Next p

End Sub

代码如下。

打开你的Excel文件，按“Alt+F11”打开VBA编辑窗口，然后在左侧对应的Sheet上双击，右侧空白处粘贴下面的代码。关闭VBA窗口。然后按“Alt+F8”打开宏窗口，选择刚插入的宏，点击“执行”。

Sub xh()

Dim rg As Range

Dim i, r, n As Long

r = Cells(Rows.Count, 2).End(xlUp).Row

For Each rg In Range("B2:B" & r)

    If rg.Row = 2 Then

        n = 0

    Else

        If rg.Value = rg.Offset(-1, 0).Value Then n = n + 1 Else n = 0

    End If

    rg.Offset(0, -1).Value = n

Next

For i = r To 2 Step -1

    If Cells(i, 1) = 0 Then

        If Cells(i + 1, 1) <> 1 Then Rows(i).Delete

    Else

        If Cells(i + 1, 1).Value = 0 Then Rows(i + 1).Insert: Cells(i + 1, 1).Value = "End"

    End If

Next

End Sub

---