时间戳

首页 > 解决方案 > 如果匹配，则匹配第一列的第一行，然后将其对应的第二列行发送到 Word 文档中

excel - 如果匹配，则匹配第一列的第一行，然后将其对应的第二列行发送到 Word 文档中

问题描述

我有一个包含两列需求和来源的 excel。我在 excel 中有另一个带有 Requirement 的 Word 文档。我希望它匹配。如果匹配，则需要将其对应的来源发送到word文档中的Requirement。 excel文件数据：

在 word 文档中，数据应如下所示： 在此处输入图像描述

我试过这样：

Sub SearchItem()
  Dim shtSearchItem As Worksheet
  Dim shtExtract As Worksheet
  Dim oWord As Word.Application
  Dim WordNotOpen As Boolean
  Dim oDoc As Word.Document
  Dim oRange As Word.Range
  Dim LastRow As Long
  Dim CurrRowShtSearchItem As Long
  Dim CurrRowShtExtract As Long
  Dim myPara As Long


  On Error Resume Next

  Set oWord = GetObject(, "Word.Application")

  If Err Then
    Set oWord = New Word.Application
    WordNotOpen = True
  End If

  On Error GoTo Err_Handler

  oWord.Visible = True
  oWord.Activate
  Set oDoc = oWord.Documents.Open("File Location")     

  Set shtSearchItem = ThisWorkbook.Worksheets(1)
  If ThisWorkbook.Worksheets.Count < 2 Then
      ThisWorkbook.Worksheets.Add After:=shtSearchItem
  End If
  Set shtExtract = ThisWorkbook.Worksheets(2)

  LastRow = shtSearchItem.UsedRange.Rows(shtSearchItem.UsedRange.Rows.Count).Row

  For CurrRowShtSearchItem = 2 To LastRow
    Set oRange = oDoc.Range
      With oRange.Find
        .Text = shtSearchItem.Cells(CurrRowShtSearchItem, 1).Text
        .MatchCase = False
        .MatchWholeWord = True
        While oRange.Find.Execute = True
            oRange.Select
            If .Found Then
                oRange.InsertAfter ("Reference" & ":")   ' <= what need to be done?


            End If
            oRange.Start = oRange.End
            oRange.End = ActiveDocument.Range.End
            oRange.Collapse wdCollapseEnd
       Wend
     End With
  Next CurrRowShtSearchItem

  If WordNotOpen Then
    oWord.Quit
  End If

  'Release object references

  Set oWord = Nothing
  Set oDoc = Nothing

  Exit Sub
  Err_Handler:
  MsgBox "Word caused a problem. " & Err.Description, vbCritical, "Error: " & Err.Number
  If WordNotOpen Then
    oWord.Quit

  End If

End Sub

请帮忙。谢谢你

标签： excelvbams-word

解决方案

尝试基于以下内容：

Sub SendRefsToDoc()
'Note: A reference to the Word library must be set, via Tools|References
Dim wdApp As New Word.Application, wdDoc As Word.Document, StrNm As String
Dim r As Long, xlFList As String, xlRList As String
StrNm = "C:\Users\" & Environ("UserName") & "\Documents\MyDocument.docx"
If Dir(StrNm) <> "" Then
  With Worksheets("Sheet1")
    For r = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
      If .Range("A" & r).Text = "" Then
      xlRList = xlRList & ", " & Trim(.Range("B" & r))
      Else
        xlFList = xlFList & "|" & Trim(.Range("A" & r))
        xlRList = xlRList & "|" & Trim(.Range("B" & r))
      End If
    Next
  End With
  With wdApp
    .Visible = False
    Set wdDoc = Documents.Open(Filename:=StrNm, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      For r = 1 To UBound(Split(xlFList, "|"))
        With .Range
          With .Find
            .Replacement.ClearFormatting
            .Text = Split(xlFList, "|")(r)
            .Replacement.Text = ""
            .Forward = True
            .Format = False
            .Wrap = wdFindStop
          End With
          Do While .Find.Execute
            .Paragraphs.First.Range.Characters.Last.InsertBefore vbCr _ 
              & "Reference: " & Split(xlRList, "|")(r)
            With .Paragraphs.First.Range.Font
              .Bold = True
              .Italic = True
            End With
            With .Paragraphs.Last.Range.Font
              .Bold = False
              .Italic = False
            End With
            .Collapse wdCollapseEnd
          Loop
        End With
      Next
      .Close True
    End With
    .Quit
  End With
Else
  MsgBox "File not found: " & vbCr & StrNm, vbExclamation
End If
Set wdDoc = Nothing: Set wdApp = Nothing
End Sub

推荐阅读