VBA to apply filter and fill a column using vlookup

[ajeya]

Hello !

I was trying to apply Vlookup on a new column created with the reference table in another workbook.

What I'm trying to achieve:

> Column S in "Working IC" workbook, with sheet "Subs Console" has the Party Name column from where I want to compare the Party names from another workbook "MacroRUN.xlsm" havin sheet "Party Name".

> Sheet "Party Name" has column A similar to column S in "Subs Console" sheet of another workbook.

> Sheet "Party Name" has column B which we want to lookup and apply on sheet "Subs Console" of another workbook in column AZ with reference to Party name.

ActiveSheet.UsedRange.AutoFilter Field:=48, Criteria1:="AP"
    
    Dim ws As Worksheet
    Set ws = Sheets("Subs Console")
    
    Windows("Working IC.xlsx").Activate
    Sheets("Subs Console").Select
    
    Dim c As Range
    
        For Each c In ws.UsedRange.Columns("AZ").Cells
        
            On Error Resume Next
            c.Value = Application.WorksheetFunction.VLookup(c, Sheets("Party Name").Range("A:B"), 2, False)
            
        Next c

 

[ajeya]

Yeah sure JackDanIce. Here is the full code that I was earlier using:

Sub RUN()
'
' RUN Macro
'


'
    Windows("Working IC.xlsx").Activate
    Sheets("Subs Console").Select
    
    Range("AZ5").Select
    ActiveCell.FormulaR1C1 = "Remarks"
    Range("AY5").Select
    Selection.Copy
    Range("AZ5").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Range("AV5").Select
    Selection.AutoFilter
    
    ' For First criteria AP
    ActiveSheet.UsedRange.AutoFilter Field:=48, Criteria1:="AP"
    
    Dim ws As Worksheet
    Set ws = Sheets("Subs Console")
    
    Windows("MacroRUN.xlsm").Activate
    Sheets("Party Name").Select
    
    Dim rg As Range
    Set rg = ActiveSheet.Range("A:B")
    
    
    Windows("Working IC.xlsx").Activate
    Sheets("Subs Console").Select
    
    
    Dim c As Range
    
        For Each c In ws.UsedRange.Columns("AZ").Cells
            On Error Resume Next
            c.Value = Application.WorksheetFunction.VLookup(c, rg, 2, False)
            
        Next c
           
    
    
    
    ' For Second criteria EAR
    
    ActiveSheet.UsedRange.AutoFilter Field:=48, Criteria1:="EAR"
    
    Windows("MacroRUN.xlsm").Activate
    Sheets("Line Description").Select
    
    Dim rg2 As Range
    Set rg2 = ActiveSheet.Range("A:B")
    
    
    Windows("Working IC.xlsx").Activate
    Sheets("Subs Console").Select
    
    
    Dim c2 As Range
    
        For Each c2 In ws.UsedRange.Columns("AZ").Cells
           On Error Resume Next
           c2.Value = Application.WorksheetFunction.VLookup(c2, rg2, 2, False)
        Next c2
           
  ActiveSheet.ShowAllData
              
End Sub

 

[JackDanIce]

Untested, but try following:

Sub Run2()

    Dim arr()   As Variant
    Dim dic     As Object
    Dim x       As Long
    
    Set dic = CreateObject("Scripting.Dicttionary")
    
    With Workbooks("MacroRUN.xlsm").Sheets("Party Name")
        x = .Cells(.Rows.count, 2).End(xlUp)
        arr = .Cells(1, 1).Resize(x, 2).Value
        For x = LBound(arr, 1) To UBound(arr, 1)
            dic(arr(x, 1)) = arr(x, 2)
        Next x
    End With
    Erase arr
    
    With Workbooks("Working IC.xlsx").Sheets("Subs Console")
        With .Range("AZ5")
            .Value = "Remarks"
            .Offset(, -1).Copy
            .PasteSpecial xlPasteFormats
        End With
        Application.CutCopyMode = False
            
        x = .Range("AV" & Rows.count).End(xlUp).row - 4
        arr = .Range("AV5:AV" & x).Value
       
        For x = LBound(arr, 1) To UBound(arr, 1)
            If UCase$(CStr(arr(x, 1))) = "AP" Or UCase$(CStr(arr(x, 1))) = "EAR" Then arr(x, 1) = dic(arr(x, 1))
        Next x
        
        .Range("AV5").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
    End With
    Erase arr
    
    Set dic = Nothing

End Sub