Копирование текста соседней ячейки 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», но скопировать aaaa@gmail.com »в текстовом документе. См. Изображение для лучшего понимания.

Answer 1

Для другого подхода попробуйте:

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 (вы можете изменить ссылки на столбцы, если вы sh).

В кодированном виде адреса электронной почты вставляются в виде простых текстовых строк. Если вы хотите, чтобы они были отформатированы как гиперссылки, вставьте:

'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

Answer 2

Краткий ответ: используйте .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