復制Excel的相鄰單元格文本

Question

我需要在 Microsoft Word 中有一個宏，我在其中搜索 Excel 中的指定單詞（例如名稱），但復制右側單元格的文本（電子郵件）。 這就是我為解決問題所做的工作：

Dim xlApp As New Excel.Application, xlWkBk As Excel.Workbook
Dim StrWkBkNm As String, StrWkShtNm As String, LRow As Long, i As Long
StrWkBkNm = ActiveDocument.Path & "\BD.xlsx"
StrWkShtNm = "Hoja2"
With xlApp
  Set xlWkBk = .Workbooks.Open(StrWkBkNm) '''''''''''''''''''
  With xlWkBk
      With .Worksheets(StrWkShtNm)
        .Cells.Find(What:="Prueba", After:=ActiveCell, LookAt _
    :=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _
    False, SearchFormat:=False).Activate
    Selection.Copy
      End With
    .Close False
  End With
  .Quit
End With
Selection.Paste

例如，我需要搜索名稱“AAAA”，但在word文檔中復制“aaaa@gmail.com”。查看圖片以便更好地理解。

Answer 1

簡短回答：使用.Offset(0, 1)使單元格向右

更長的答案：這里有很多改進的機會

考慮一下代碼的重構：

Sub Demo()
    Dim xlApp As Excel.Application, xlWkBk As Excel.Workbook, xlWkSh As Excel.Worksheet
    Dim rng As Excel.Range
    Dim WkBkNm As String, WkShtNm As String
    Dim WorkerColumn As Long
    Dim SearchTerm As String

    Set xlApp = New Excel.Application
    WkBkNm = ActiveDocument.Path & "\BD.xlsx"
    WkShtNm = "Hoja2"
    SearchTerm = "Prueba"
    WorkerColumn = 1 'Update this

    With xlApp
        On Error Resume Next
            Set xlWkBk = .Workbooks.Open(WkBkNm)
        On Error GoTo 0
        If xlWkBk Is Nothing Then
            ' File failed to open, what now?
            GoTo CleanUp
        End If
        On Error Resume Next
            Set xlWkSh = xlWkBk.Worksheets(WkShtNm)
        On Error GoTo 0
        If xlWkSh Is Nothing Then
            ' Worksheet doesn't exist, what now?
            GoTo CleanUp
        End If
        With xlWkSh
            ' you should limit the search to the Worker column
            Set rng = .Columns(WorkerColumn).Find( _
              What:=SearchTerm, _
              After:=Excel.Cells(1, WorkerColumn), _
              LookAt:=Excel.xlPart, _
              SearchOrder:=Excel.xlByColumns, _
              SearchDirection:=Excel.xlNext, _
              MatchCase:=False, _
              SearchFormat:=False)
            ' test for value not found
            If Not rng Is Nothing Then
                rng.Offset(0, 1).Copy ' offset to get next column
                Word.Selection.Paste  'disambiguate
            End If
        End With
    End With
CleanUp:
    On Error Resume Next
    If Not xlWkBk Is Nothing Then xlWkBk.Close False
    xlApp.Quit
End Sub

Answer 2

對於不同的方法，請嘗試：

Sub BulkFindReplace()
Application.ScreenUpdating = False
Dim xlApp As Object, xlWkBk As Object, StrWkBkNm As String, StrWkSht As String
Dim iDataRow As Long, xlFList As String, xlRList As String, i As Long
StrWkBkNm = ActiveDocument.Path & "\BD.xlsx"
StrWkSht = "Hoja2"
If Dir(StrWkBkNm) = "" Then
  MsgBox "Cannot find the designated workbook: " & StrWkBkNm, vbExclamation
  Exit Sub
End If
On Error Resume Next
'Start Excel
Set xlApp = CreateObject("Excel.Application")
If xlApp Is Nothing Then
  MsgBox "Can't start Excel.", vbExclamation
  Exit Sub
End If
On Error GoTo 0
With xlApp
  'Hide our Excel session
  .Visible = False
  ' The file is available, so open it.
  Set xlWkBk = .Workbooks.Open(FileName:=StrWkBkNm, ReadOnly:=True, AddToMru:=False)
  If xlWkBk Is Nothing Then
    MsgBox "Cannot open:" & vbCr & StrWkBkNm, vbExclamation
    .Quit: Set xlApp = Nothing: Exit Sub
  End If
  ' Process the workbook.
  With xlWkBk
    With .Worksheets(StrWkSht)
      ' Find the last-used row in column A.
      iDataRow = .Cells(.Rows.Count, 1).End(-4162).Row ' -4162 = xlUp
      ' Capture the F/R data.
      For i = 1 To iDataRow
        ' Skip over empty fields to preserve the underlying cell contents.
        If Trim(.Range("A" & i)) <> vbNullString Then
          xlFList = xlFList & "|" & Trim(.Range("A" & i))
          xlRList = xlRList & "|" & Trim(.Range("B" & i))
        End If
      Next
    End With
  .Close False
  End With
  .Quit
End With
' Release Excel object memory
Set xlWkBk = Nothing: Set xlApp = Nothing
'Exit if there are no data
If xlFList = "" Then Exit Sub
'Process each word from the F/R List
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .MatchWholeWord = True
  .MatchCase = True
  .Wrap = wdFindContinue
  For i = 1 To UBound(Split(xlFList, "|"))
    .Text = Split(xlFList, "|")(i)
    .Replacement.Text = Split(xlRList, "|")(i)
    .Execute Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub

使用上面的代碼，您不需要指定搜索詞 - 宏只是處理 A 列中的所有潛在詞，並將它們替換為 B 列中相應的 email 地址（如果您願意，可以更改列引用）。

按照編碼，email 地址作為簡單文本字符串插入。 如果您希望將它們格式化為超鏈接，請插入：

'Get current autoformat options
With Options
  bHead = .AutoFormatApplyHeadings
  bList = .AutoFormatApplyLists
  bBullet = .AutoFormatApplyBulletedLists
  bOther = .AutoFormatApplyOtherParas
  bQuote = .AutoFormatReplaceQuotes
  bSymbol = .AutoFormatReplaceSymbols
  bOrdinal = .AutoFormatReplaceOrdinals
  bFraction = .AutoFormatReplaceFractions
  bEmphasis = .AutoFormatReplacePlainTextEmphasis
  bHLink = .AutoFormatReplaceHyperlinks
  bStyle = .AutoFormatPreserveStyles
  bMail = .AutoFormatPlainTextWordMail
  bTag = .LabelSmartTags
End With
'Restrict autoformat options to emails
With Options
  .AutoFormatApplyHeadings = False
  .AutoFormatApplyLists = False
  .AutoFormatApplyBulletedLists = False
  .AutoFormatApplyOtherParas = False
  .AutoFormatReplaceQuotes = False
  .AutoFormatReplaceSymbols = False
  .AutoFormatReplaceOrdinals = False
  .AutoFormatReplaceFractions = False
  .AutoFormatReplacePlainTextEmphasis = False
  .AutoFormatReplaceHyperlinks = False
  .AutoFormatPreserveStyles = False
  .AutoFormatPlainTextWordMail = True
  .LabelSmartTags = False
End With

后：

If xlFList = "" Then Exit Sub

並插入：

'Restore the original autoformat options
With Options
  .AutoFormatApplyHeadings = bHead
  .AutoFormatApplyLists = bList
  .AutoFormatApplyBulletedLists = bBullet
  .AutoFormatApplyOtherParas = bOther
  .AutoFormatReplaceQuotes = bQuote
  .AutoFormatReplaceSymbols = bSymbol
  .AutoFormatReplaceOrdinals = bOrdinal
  .AutoFormatReplaceFractions = bFraction
  .AutoFormatReplacePlainTextEmphasis = bEmphasis
  .AutoFormatReplaceHyperlinks = bHLink
  .AutoFormatPreserveStyles = bStyle
  .AutoFormatPlainTextWordMail = bMail
  .LabelSmartTags = bTag
End With

前：

Application.ScreenUpdating = True