VBA - 从 Excel 创建 Word 文档并编辑某些行以包含粗体文本答案

【问题标题】：VBA - Creating Word Document from Excel and Edit Certain Line to Contain Bold TextVBA - 从 Excel 创建 Word 文档并编辑某些行以包含粗体文本
【发布时间】：2017-08-12 02:25:43
【问题描述】：

我希望在从 Excel 电子表格接收输入的 Word 文档中每隔两行条目加粗。换句话说，我希望生成的 word 文档的每一行都包含“ID：”以包含粗体文本。我查看了其他示例，但我不断收到诸如不匹配之类的错误。

Sub ExceltoWord_TestEnvironment()
    Dim wApp As Object
    Dim wDoc As Object
    Dim strSearchTerm
    Dim FirstMatch As Range
    Dim FirstAddress
    Dim intMyVal As String
    Dim lngLastRow As Long
    Dim strRowNoList As String
    Dim intPlaceHolder As Integer

Set wApp = CreateObject("Word.Application")
Set wDoc = CreateObject("Word.Document")
wApp.Visible = True

Set wDoc = wApp.Documents.Add

wDoc.Range.ParagraphFormat.SpaceBefore = 0
wDoc.Range.ParagraphFormat.SpaceAfter = 0

strSearchTerm = InputBox("Please enter the date to find", "Search criteria")


If strSearchTerm <> "" Then
    Set FirstMatch = ActiveSheet.Cells.Find(strSearchTerm, LookAt:=xlPart, MatchCase:=False)

        If FirstMatch Is Nothing Then
            MsgBox "That date could not be found"
        Else

            FirstAddress = FirstMatch.Address
            intMyVal = strSearchTerm
            lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row 'Search Column F, change as required.

        For Each cell In Range("F1:F" & lngLastRow) 'F is column
            If InStr(1, cell.Value, intMyVal) Then
                If strRowNoList = "" Then

                    strRowNoList = strRowNoList & cell.Row
                    intPlaceHolder = cell.Row

        wDoc.Content.InsertAfter "Group:             " & Cells(intPlaceHolder, 3) & vbNewLine
        wDoc.Content.InsertAfter "ID:         " & Cells(intPlaceHolder, 2) & vbNewLine
        wDoc.Content.InsertAfter "Name:              " & vbNewLine & vbNewLine
Else

                strRowNoList = strRowNoList & ", " & cell.Row
                intPlaceHolder = cell.Row

        wDoc.Content.InsertAfter "Group:             " & Cells(intPlaceHolder, 3) & vbNewLine
        wDoc.Content.InsertAfter "ID:         " & Cells(intPlaceHolder, 2) & vbNewLine
        wDoc.Content.InsertAfter "Name:              " & vbNewLine & vbNewLine

End If
            Next cell
            MsgBox strRowNoList

While Not FirstMatch Is Nothing
            Set FirstMatch = ActiveSheet.Cells.FindNext(FirstMatch)
        If FirstMatch.Address = FirstAddress Then
            Set FirstMatch = Nothing


        End If
        Wend
    End If

End If

End Sub

例子：

组：A组

ID：123456

姓名：琼恩·雪诺

组：B组

ID：789101

姓名：山姆威尔·塔利

【问题讨论】：

标签： vba excel ms-word

【解决方案1】：

我找到了解决办法。以为我会在这里发布以帮助其他人。抱歉，我的代码没有我希望的那么干净。复制和粘贴不太匹配。

Sub ExceltoWord_TestEnvironment()
    Dim wApp As Object
    Dim wDoc As Object
    Dim strSearchTerm
    Dim FirstMatch As Range
    Dim FirstAddress
    Dim intMyVal As String
    Dim lngLastRow As Long
    Dim strRowNoList As String
    Dim intPlaceHolder As Integer

Set wApp = CreateObject("Word.Application")
Set wDoc = CreateObject("Word.Document")
wApp.Visible = True

Set wDoc = wApp.Documents.Add

wDoc.Range.ParagraphFormat.SpaceBefore = 0
wDoc.Range.ParagraphFormat.SpaceAfter = 0

strSearchTerm = InputBox("Please enter the date to find", "Search criteria")


If strSearchTerm <> "" Then
    Set FirstMatch = ActiveSheet.Cells.Find(strSearchTerm, LookAt:=xlPart, MatchCase:=False)

        If FirstMatch Is Nothing Then
            MsgBox "That date could not be found"
        Else

            FirstAddress = FirstMatch.Address
            intMyVal = strSearchTerm
            lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row 'Search Column F, change as required.

        For Each cell In Range("F1:F" & lngLastRow) 'F is column
            If InStr(1, cell.Value, intMyVal) Then
                If strRowNoList = "" Then

                    strRowNoList = strRowNoList & cell.Row
                    intPlaceHolder = cell.Row
     intParaCount = wDoc.Paragraphs.Count

             i = 2
         Set objParagraph = wDoc.Paragraphs(i).Range
         With objParagraph
             .Font.Bold = True
         End With

        wDoc.Content.InsertAfter "Group:             " & Cells(intPlaceHolder, 3) & vbNewLine
        wDoc.Content.InsertAfter "ID:         " & Cells(intPlaceHolder, 2) & vbNewLine
        wDoc.Content.InsertAfter "Name:              " & vbNewLine & vbNewLine

         i = i + 4 'paragraph number

Else

                strRowNoList = strRowNoList & ", " & cell.Row
                intPlaceHolder = cell.Row

        wDoc.Content.InsertAfter "Group:             " & Cells(intPlaceHolder, 3) & vbNewLine
        wDoc.Content.InsertAfter "ID:         " & Cells(intPlaceHolder, 2) & vbNewLine
        wDoc.Content.InsertAfter "Name:              " & vbNewLine & vbNewLine

            i = i + 4

End If
            Next cell
            MsgBox strRowNoList

While Not FirstMatch Is Nothing
            Set FirstMatch = ActiveSheet.Cells.FindNext(FirstMatch)
        If FirstMatch.Address = FirstAddress Then
            Set FirstMatch = Nothing


        End If
        Wend
    End If

End If

End Sub

代码使用 .paragraphs() 其中“i”是您要加粗的段落：

   i = 2
     Set objParagraph = wDoc.Paragraphs(i).Range
     With objParagraph
         .Font.Bold = True
     End With

并且每次迭代后都会加上段落的差异

i = i + 4 'paragraph number

【讨论】：