vba - 粗体和下划线只是字符串的一部分

Question

所以......我有这个表单，人们从列表框中选择不同的控件（我们称之为安全措施控件，这些不是内容控件）并将它们添加到列表中。这是在重复表中。每个控件都有一个标题标签（“工程”“管理”或“PPE”，我想加粗并加下划线，但我希望列表框中选择的选项采用正常格式。打印到的代码部分文档如下所示：

  
    Set tableSequence = ActiveDocument.Tables(1)
    Set NewRow = tableSequence.Rows.Add
 
NewRow.Cells(5).Range.Text = "Engineering: " & MyString3 _
        & vbCrLf & "Administrative: " _
        & MyString4 & vbCrLf _
        & "PPE: " & MyString5

我希望 Engineering、Administrative 和 PPE 加粗并加下划线，并且 MyString 对象表示的项目以标准格式显示。谢谢你。

字符串部分如下：

Private Sub CommandButton6_Click()
    Dim tableSequence As Table
    Dim NewRow As Row
    Dim MyString5 As String
    Dim v As Variant
    Dim var3
    Dim p As String
    Dim M As Long
    
    For var3 = 0 To ListBox7.ListCount - 1
    If ListBox7.Selected(var3) = True Then
    MyString5 = MyString5 & ListBox7.List(var3)
    v = Split(MyString5, ",")
    p = ""
    For M = LBound(v) To UBound(v)
    p = p + v(M)
    If M Mod 3 = 2 Then
    p = p + vbCr
    Else
    p = p + ","
    End If
Next M
p = Left(p, Len(p) - 1)
Debug.Print p
End If

很抱歉把它漏掉了

标签： vbams-word

Answer 1

如何格式化 Word 表格中单元格值的一部分（或多个部分）：

我不得不承认我不是很喜欢 Word VBA，但我为你把这个 Sub 拼接在一起，它在我的测试文档中工作。根据您的需要进行调整。

Option Explicit
Sub asd()
Dim tableSequence As Table
Set tableSequence = ActiveDocument.Tables(1)
Dim NewRow As Row
Set NewRow = tableSequence.Rows.Add

NewRow.Cells(5).Range.Text = "Engineering: asd" & vbCrLf & "Administrative: vvv" & vbCrLf & "test" & vbCrLf & "PPE: blabla"
NewRow.Cells(5).Range.Bold = False
NewRow.Cells(5).Range.Underline = False

Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")

Dim keyword As Variant
Dim myRange As Variant
Dim startPos As Integer
Dim endPos As Integer
Dim length As Integer
Dim i As Integer
i = 1

For Each keyword In keywordArr

    Do While InStr(1, myRange, keyword) = 0
        Set myRange = NewRow.Cells(5).Range.Paragraphs(i).Range
        i = i + 1
    Loop
    startPos = InStr(1, myRange, keyword)
    startPos = myRange.Characters(startPos).Start
    length = Len(keyword)
    endPos = startPos + length
    
    Set myRange = ActiveDocument.Range(startPos, endPos)
    With myRange.Font
        .Bold = True
        .Underline = True
    End With
Next keyword

End Sub

以下是 Excel 中相同内容的解决方案：

首先，您必须像以前一样将文本写入单元格。

接下来是查找关键字在单元格值中的位置+关键字的长度，如下所示

startPos = Instr(1, NewRow.Cells(5), "Engineering:")
length = len("Engineering:")

然后你可以通过设置找到的子字符串的字体Range.Characters.Font

NewRow.Cells(5).Characters(startPos, Length).Font.Bold = True
NewRow.Cells(5).Characters(startPos, Length).Font.Underline = True

现在优雅的方法是拥有一组关键字并遍历它们以更改所有关键字的字体

Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")

Dim keyword As Variant
Dim startPos as Integer
Dim length as Integer

For Each keyword In keywordArr
    startPos = InStr(1, NewRow.Cells(5), keyword)
    length = Len(keyword)

    With NewRow.Cells(5).Characters(startPos, Length).Font
        .Bold = True
        .Underline = True
    End With
Next keyword