Alternative macro to replace multiple for loops in vlookup to enable code to execute faster

hrh_dash 

Does this work?

Sub vlkuptoDCconsol()
    
    Application.ScreenUpdating = False
    
    Dim ws          As Worksheet
    Dim Destwb      As Workbook
    Dim Destws      As Worksheet
    Dim wsrng       As Range
    Dim wsrng2       As Range
    Dim wsrng3       As Range
    Dim wsrng4       As Range
    Dim i           As Long
    Dim DestwslastRow As Long
    Dim DestwslastRow2 As Long
    
    Dim find_LOD1   As Range
    Dim find_DC2    As Range
    Dim find_DC1    As Range
    Dim find_MISC   As Range
    
    Dim LOD1_startrow As Long
    Dim LOD1_lastrow As Long
    Dim DC2_startrow As Long
    Dim DC2_lastrow As Long
    Dim DC1_startrow As Long
    Dim DC1_lastrow As Long
    Dim MISC_startrow As Long
    Dim MISC_lastrow As Long
    
    Dim str         As String
    
    str = InputBox("Has Column B being sorted? Y/N")
    
    If str = "N" Then
        
        Exit Sub
        
    Else
        
        On Error Resume Next
        
        Set ws = ThisWorkbook.Sheets("Return To vlkup DC consol")
        
        Set Destwb = Workbooks.Open("\\fenton801\CorpSVC2\Finance\Systems-Risk-ERM\OrderToCash\C2C\Misc files\DC consol - Mobile Consumer.xlsx")
        Set Destws = Destwb.Sheets("Rapid - List With DC")
        Set find_LOD1 = ws.Cells.Find(What:="LOD1", After:=ws.Cells(Rows.Count, 1), LookIn:=xlValues, LookAt:= _
            xlPart, MatchCase:=False)
        
        DestwslastRow = Destws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        If Not find_LOD1 Is Nothing Then
            
            LOD1_startrow = ws.Range("B:B").Find(What:="LOD1", After:=ws.Range("B1")).Row
            LOD1_lastrow = ws.Range("B:B").Find(What:="LOD1", After:=ws.Range("B1"), SearchDirection:=xlPrevious).Row
            Destws.Range("J:K").EntireColumn.Insert
            Set wsrng = ws.Range("D" & LOD1_startrow & ":P" & LOD1_lastrow)
            With Destws.Range("J2:J" & DestwslastRow)
                .NumberFormat = "dd-mmm-yy"
                .Formula = "=VLOOKUP(A2," & wsrng.Address(External:=True) & ",12,FALSE)"
                .Value = .Value
            End With
            With Destws.Range("K2:K" & DestwslastRow)
                .Formula = "=VLOOKUP(A2," & wsrng.Address(External:=True) & ",13,FALSE)"
                .Value = .Value
            End With
            
            Destws.AutoFilter.Sort.SortFields. _
                                               Clear
            Destws.AutoFilter.Sort.SortFields. _
                                               Add2 Key:=Range("J1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
                                               DataOption:=xlSortNormal
            With Destws.AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            DestwslastRow2 = Destws.Cells(Destws.Rows.Count, "J").End(xlUp).Row
            
            Destws.Range("J2:K" & DestwslastRow2).Copy
            Destws.Range("L2:M" & DestwslastRow2).PasteSpecial xlValues
            Destws.Range("J:K").EntireColumn.Delete
            
        End If
        
        Set find_DC2 = ws.Cells.Find(What:="DC2", After:=ws.Cells(Rows.Count, 1), LookIn:=xlValues, LookAt:= _
            xlPart, MatchCase:=False)
        
        DestwslastRow = Destws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        If Not find_DC2 Is Nothing Then
            DC2_startrow = ws.Range("B:B").Find(What:="DC2", After:=ws.Range("B1")).Row
            DC2_lastrow = ws.Range("B:B").Find(What:="DC2", After:=ws.Range("B1"), SearchDirection:=xlPrevious).Row
            Destws.Range("AA:AB").EntireColumn.Insert
            Set wsrng2 = ws.Range("D" & DC2_startrow & ":P" & DC2_lastrow)
            With Destws.Range("AA2:A" & DestwslastRow)
                .NumberFormat = "dd-mmm-yy"
                .Formula = "=VLOOKUP(A2," & wsrng2.Address(External:=True) & ",12,FALSE)"
                .Value = .Value
            End With
            With Destws.Range("AB2:AB" & DestwslastRow)
                .Formula = "=VLOOKUP(A2," & wsrng2.Address(External:=True) & ",13,FALSE)"
                .Value = .Value
            End With
            
            Destws.AutoFilter.Sort.SortFields. _
                                               Clear
            Destws.AutoFilter.Sort.SortFields. _
                                               Add2 Key:=Range("AA1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
                                               DataOption:=xlSortNormal
            With Destws.AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            DestwslastRow2 = Destws.Cells(Destws.Rows.Count, "AA").End(xlUp).Row
            
            Destws.Range("AA2:AB" & DestwslastRow2).Copy
            Destws.Range("AC2:AD" & DestwslastRow2).PasteSpecial xlValues
            Destws.Range("AA:AB").EntireColumn.Delete
            
        End If
        
        Set find_DC1 = ws.Cells.Find(What:="DC1", After:=ws.Cells(Rows.Count, 1), LookIn:=xlValues, LookAt:= _
            xlPart, MatchCase:=False)
        
        DestwslastRow = Destws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        If Not find_DC1 Is Nothing Then
            DC1_startrow = ws.Range("B:B").Find(What:="DC1", After:=ws.Range("B1")).Row
            DC1_lastrow = ws.Range("B:B").Find(What:="DC1", After:=ws.Range("B1"), SearchDirection:=xlPrevious).Row
            Destws.Range("T:U").EntireColumn.Insert
            Set wsrng3 = ws.Range("D" & DC1_startrow & ":P" & DC1_lastrow)
             With Destws.Range("T2:T" & DestwslastRow)
                .NumberFormat = "dd-mmm-yy"
                .Formula = "=VLOOKUP(A2," & wsrng3.Address(External:=True) & ",12,FALSE)"
                .Value = .Value
            End With
            With Destws.Range("U2:U" & DestwslastRow)
                .Formula = "=VLOOKUP(A2," & wsrng3.Address(External:=True) & ",13,FALSE)"
                .Value = .Value
            End With
           
            Destws.AutoFilter.Sort.SortFields. _
                                               Clear
            Destws.AutoFilter.Sort.SortFields. _
                                               Add2 Key:=Range("T1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
                                               DataOption:=xlSortNormal
            With Destws.AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            DestwslastRow2 = Destws.Cells(Destws.Rows.Count, "T").End(xlUp).Row
            
            Destws.Range("T2:U" & DestwslastRow2).Copy
            Destws.Range("V2:W" & DestwslastRow2).PasteSpecial xlValues
            Destws.Range("T:U").EntireColumn.Delete
            
        End If
        
        Set find_MISC = ws.Cells.Find(What:="MISC", After:=ws.Cells(Rows.Count, 1), LookIn:=xlValues, LookAt:= _
            xlPart, MatchCase:=False)
        
        DestwslastRow = Destws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        If Not find_MISC Is Nothing Then
            DC1_startrow = ws.Range("B:B").Find(What:="MISC", After:=ws.Range("B1")).Row
            DC1_lastrow = ws.Range("B:B").Find(What:="MISC", After:=ws.Range("B1"), SearchDirection:=xlPrevious).Row
            Destws.Range("J:K").EntireColumn.Insert
            Set wsrng4 = ws.Range("D" & DC1_startrow & ":P" & DC1_lastrow)
            With Destws.Range("J2:J" & DestwslastRow)
                .NumberFormat = "dd-mmm-yy"
                .Formula = "=VLOOKUP(A2," & wsrng4.Address(External:=True) & ",12,FALSE)"
                .Value = .Value
            End With
            With Destws.Range("K2:K" & DestwslastRow)
                .Formula = "=VLOOKUP(A2," & wsrng4.Address(External:=True) & ",13,FALSE)"
                .Value = .Value
            End With
            
            Destws.AutoFilter.Sort.SortFields. _
                                               Clear
            Destws.AutoFilter.Sort.SortFields. _
                                               Add2 Key:=Range("J1"), SortOn:=xlSortOnValues, Order:=xlAscending, _
                                               DataOption:=xlSortNormal
            With Destws.AutoFilter.Sort
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
            
            DestwslastRow2 = Destws.Cells(Destws.Rows.Count, "J").End(xlUp).Row
            
            Destws.Range("J2:K" & DestwslastRow2).Copy
            Destws.Range("L2:M" & DestwslastRow2).PasteSpecial xlValues
            Destws.Range("J:K").EntireColumn.Delete
            
        End If
        
    End If
    
    Application.ScreenUpdating = True
    
End Sub