Find Matches in Column and Replace from External File - excel

Question

I use this VBA code which works very well. It searches in column A of an external Excel file for all the terms in column D, and replaces the matches, with the content of column B of the external file in the found row. So for instance:
if D5 matches A11 of the external file, then B11 from external file is written to D5.
I am now trying to modify it so that it still searches in column 4 for matches in column A of external file, but for any matches found, replaces the column E with column B of the external file. So:
If D5 matches A11, then B11 from external file is written to E5.
Well, I've tried many changes in the replace loop but it throws errors every time. I suppose I don't use the correct command!
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook, thisWb As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet
Dim i As Long, lRow As Long
'This is the workbook from where code runs
Set thisWb = ThisWorkbook
Set thisWs = thisWb.Sheets("Sheet1")
'External file
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
Set NameListWS = NameListWB.Worksheets("Sheet1")
With NameListWS
'Detect end row in Col A of Data.xlsx
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'Loop though Column A
For i = 1 To lRow
'... and perform replace action
thisWs.Columns(4).Replace What:=.Range("A" & i).Value, _
Replacement:=.Range("B" & i).Value, _
SearchOrder:=xlByColumns, _
MatchCase:=False
Next i
End With
End Sub ```

Answer 1

Untested:
Private Sub CommandButton1_Click()
Dim NameListWB As Workbook
Dim NameListWS As Worksheet, thisWs As Worksheet, n As Long
Dim i As Long, arrList, arrD, rngD As Range
Set thisWs = ThisWorkbook.Sheets("Sheet1") 'This is the workbook from where code runs
'get an array from the column to be searched
Set rngD = thisWs.Range("D1:D" & thisWs.Cells(Rows.Count, "D").End(xlUp).Row)
arrD = rngD.Value
'Open external file and get the terms and replacements as an array
Set NameListWB = Workbooks.Open("E:\Data.xlsx")
With NameListWB.Worksheets("Sheet1")
arrList = .Range("A1:B" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
For n = 1 To UBound(arrD, 1) 'check each value from ColD
For i = 1 To UBound(arrList, 1) 'loop over the array of terms to search for
If arrD(n, 1) = arrList(i, 1) Then 'exact match ?
'If InStr(1, arrD(n, 1), arr(i, 1)) > 0 Then 'partial match ?
rngD.Cells(n).Offset(0, 1).Value = arrList(i, 2) 'populate value from ColB into ColE
Exit For 'got a match so stop searching
End If
Next i
Next n
End Sub

Answer 2

A VBA Lookup (Application.Match)
Adjust (play with) the values in the constants section.
Compact
Sub VBALookup()
' Source
Const sPath As String = "E:\Data.xlsx"
Const sName As String = "Sheet1"
Const slCol As String = "A" ' lookup
Const svCol As String = "B" ' value
Const sfRow As Long = 2
' Destination
Const dName As String = "Sheet1"
Const dlCol As String = "D" ' lookup
Const dvCol As String = "E" ' value
Const dfRow As Long = 2
Application.ScreenUpdating = False
' Source
Dim swb As Workbook: Set swb = Workbooks.Open(sPath)
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, slCol).End(xlUp).Row
If slRow < sfRow Then Exit Sub ' no data in lookup column range
Dim srCount As Long: srCount = slRow - sfRow + 1
Dim slrg As Range: Set slrg = sws.Cells(sfRow, slCol).Resize(srCount)
Dim svData As Variant
With slrg.EntireRow.Columns(svCol)
If srCount = 1 Then ' one cell
ReDim svData(1 To 1, 1 To 1): svData(1, 1) = .Value
Else ' multiple cells
svData = .Value
End If
End With
' Destination
Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dlCol).End(xlUp).Row
If dlRow < dfRow Then Exit Sub ' no data in lookup column range
Dim drCount As Long: drCount = dlRow - dfRow + 1
Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dlCol).Resize(drCount)
Dim dData As Variant
If drCount = 1 Then ' one cell
ReDim dData(1 To 1, 1 To 1): dData(1, 1) = dlrg.Value
Else ' multiple cells
dData = dlrg.Value
End If
' Loop.
Dim srIndex As Variant
Dim dValue As Variant
Dim dr As Long
Dim MatchFound As Boolean
For dr = 1 To drCount
dValue = dData(dr, 1)
If Not IsError(dValue) Then
If Len(dValue) > 0 Then
srIndex = Application.Match(dValue, slrg, 0)
If IsNumeric(srIndex) Then MatchFound = True
End If
End If
If MatchFound Then
dData(dr, 1) = svData(srIndex, 1)
MatchFound = False
Else
dData(dr, 1) = Empty
End If
Next dr
' Close the source workbook.
swb.Close SaveChanges:=False
' Write result.
dlrg.EntireRow.Columns(dvCol).Value = dData
' Inform.
Application.ScreenUpdating = True
MsgBox "VBA lookup has finished.", vbInformation
End Sub