Find Matches in Column and Replace from External File-CodePudding

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 ```

CodePudding user response：

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

CodePudding user response：

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

A VBA Lookup (Application.Match)

A VBA Lookup (`Application.Match`)