Copying the adjacent cell text of Excel - excel

Question

I need to have a Macro in Microsoft Word in which I search for a specified word in Excel (a name for example), but copy the text of the cell at the right (email). This is what I've done trying to solve the problem:
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
For example, I need to search for the name "AAAA", but copy aaaa#gmail.com" in the word document. See the image for better understanding.

Answer 1

For a different approach, try:
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
With the above code, you don't need to specify the search term - the macro simply processes all potential terms in column A and replaces them with the corresponding email addresses from Column B (you can change the column references if you wish).
As coded, the email addresses are inserted as simple text strings. If you want them to be formatted as hyperlinks, insert:
'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
after:
If xlFList = "" Then Exit Sub
and insert:
'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
before:
Application.ScreenUpdating = True

Answer 2

Short answer: use .Offset(0, 1) to get the cell to the right
Longer answer: there is a lot of opportunity for improvement here
Consider this refactor of your code:
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