创建标题的脚本

Question

我有一个由DOORS创建的word文档，其中表中的标题写为"；1〃"1.1〃"2.2.3"；等等(见图(。

单词表

有没有办法写一个宏或vba脚本来搜索给定列中以数字开头的单元格，然后删除数字并为行应用其中一种样式
例如：

• 交换"；1〃；以及"；2〃；用"；标题1"；从样式选择
• 交换"；1.1"；以及"；2.3〃；用"；标题2"；从样式选择
• 交换"；1.1.3"；以及"；2.3.4"；用"；标题3"；从样式选择
• 等等

提前感谢。

谨致问候，克劳斯

Answer 1

我花了一下午的时间来解决这个问题，现在它起作用了：-(

代码可能更漂亮，但它是有效的。以防其他人需要此功能。

子应用程序标题样式((Dim tbl As TableDim t单元格为单元格Dim r为整数

For Each tbl In ActiveDocument.Tables
For r = 1 To tbl.Rows.Count
Set tCell = tbl.Cell(r, 3) ' check only row 3
If tCell.Range.Text Like "#.#.#.#.#.#*" Then ' search for heading number consisting of x.x.x.x.x.x
tCell.Range.Text = Right(tCell.Range.Text, Len(tCell.Range.Text) - 12) ' remove old heading numbers
tCell.Range.Text = Replace(tCell.Range.Text, Chr(13), "") ' remove Carrige Return at end of string
tCell.Range.Style = ActiveDocument.Styles("Heading 6")
End If
Next r
Next tbl
For Each tbl In ActiveDocument.Tables
For r = 1 To tbl.Rows.Count
Set tCell = tbl.Cell(r, 3) ' check only row 3
If tCell.Range.Text Like "#.#.#.#.#*" Then ' search for heading number consisting of x.x.x.x.x
tCell.Range.Text = Right(tCell.Range.Text, Len(tCell.Range.Text) - 10) ' remove old heading numbers
tCell.Range.Text = Replace(tCell.Range.Text, Chr(13), "") ' remove Carrige Return at end of string
tCell.Range.Style = ActiveDocument.Styles("Heading 5")
End If
Next r
Next tbl
For Each tbl In ActiveDocument.Tables
For r = 1 To tbl.Rows.Count
Set tCell = tbl.Cell(r, 3) ' check only row 3
If tCell.Range.Text Like "#.#.#.#*" Then ' search for heading number consisting of x.x.x.x
tCell.Range.Text = Right(tCell.Range.Text, Len(tCell.Range.Text) - 8) ' remove old heading numbers
tCell.Range.Text = Replace(tCell.Range.Text, Chr(13), "") ' remove Carrige Return at end of string
tCell.Range.Style = ActiveDocument.Styles("Heading 4")
End If
Next r
Next tbl
For Each tbl In ActiveDocument.Tables
For r = 1 To tbl.Rows.Count
Set tCell = tbl.Cell(r, 3) ' check only row 3
If tCell.Range.Text Like "#.#.#*" Then ' search for heading number consisting of x.x.x
tCell.Range.Text = Right(tCell.Range.Text, Len(tCell.Range.Text) - 6) ' remove old heading numbers
tCell.Range.Text = Replace(tCell.Range.Text, Chr(13), "") ' remove Carrige Return at end of string
tCell.Range.Style = ActiveDocument.Styles("Heading 3")
End If
Next r
Next tbl
For Each tbl In ActiveDocument.Tables
For r = 1 To tbl.Rows.Count
Set tCell = tbl.Cell(r, 3) ' check only row 3
If tCell.Range.Text Like "#.#*" Then ' search for heading number consisting of x.x
tCell.Range.Text = Right(tCell.Range.Text, Len(tCell.Range.Text) - 4) ' remove old heading numbers
tCell.Range.Text = Replace(tCell.Range.Text, Chr(13), "") ' remove Carrige Return at end of string
tCell.Range.Style = ActiveDocument.Styles("Heading 2")
End If
Next r
Next tbl

结束子

Answer 2

刷代码。工作原理相同。

公共函数getHeadingNumber(ByRef s As String(为整数将i标注为整数将ws标注为字符串

If s Like "#.#*" Then ' is it a heading (note: heading 1 are not found)
i = InStr(s, " ") ' search for first space charater
ws = Left(s, i) ' keep only digits and bullets in ws
getHeadingNumber = 1 + Len(ws) - Len(Replace(ws, ".", "")) ' count number of bullets

s = Right(s, Len(s) - i) ' keep only the 12 left most characters
s = Replace(s, Chr(13), "") ' remove Carrige Return at end of string
Else
getHeadingNumber = 0 ' not a heading
End If

终端功能

子应用程序标题样式((Dim tbl As TableDim t单元格为单元格将r标注为整数将标题标注为整数将ws标注为字符串

For Each tbl In ActiveDocument.Tables
For r = 1 To tbl.Rows.Count
Set tCell = tbl.Cell(r, 3) ' check only row 3
ws = tCell.Range.Text
heading = getHeadingNumber(ws)
If heading > 0 Then
tCell.Range.Text = ws
Select Case heading
Case 1
tCell.Range.Style = ActiveDocument.Styles("Heading 1")
Case 2
tCell.Range.Style = ActiveDocument.Styles("Heading 2")
Case 3
tCell.Range.Style = ActiveDocument.Styles("Heading 3")
Case 4
tCell.Range.Style = ActiveDocument.Styles("Heading 4")
Case 5
tCell.Range.Style = ActiveDocument.Styles("Heading 5")
Case 6
tCell.Range.Style = ActiveDocument.Styles("Heading 6")
End Select
End If
Next r
Next tbl
' Set heading in "Test Description"
For Each tbl In ActiveDocument.Tables
Set tCell = tbl.Cell(2, 3)
If tCell.Range.Text Like "1*" Then ' search for heading
tCell.Range.Text = Right(tCell.Range.Text, Len(tCell.Range.Text) - 2) ' remove old heading numbers
tCell.Range.Text = Replace(tCell.Range.Text, Chr(13), "") ' remove Carrige Return at end of string
tCell.Range.Style = ActiveDocument.Styles("Heading 1")
End If
Next tbl

结束子