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

Question

我期望在接收来自Excel电子表格输入的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

名称：萨姆韦尔Tarly

Answer 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 

该代码利用则可对（），其中 'i' 是你要大胆的段落：

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

而且在段落后的差值每次迭代

i = i + 4 'paragraph number 

添加