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

[hrh_dash]

Is there a better way to rewrite the code (reduce the loops) so that the code could finished executing it at a faster rate?

Currently, the code takes about an average 5 - 10 mins depending on the rows being input. My Destwb is about 56k KB (quite a huge file). 

There are 4 different loops for 4 different criteria; LOD1, DC1, DC2 and MISC and it is taking quite fair bit of time despite the results are populating correctly.

Option Compare Text
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)
            
            For i = 2 To DestwslastRow
                
                Destws.Range("J" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng, 12, 0)
                Destws.Range("J:J").NumberFormat = "dd-Mmm-yy"
                
                Destws.Range("K" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng, 13, 0)
                
            Next i
            
            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)
            
            For i = 2 To DestwslastRow
                
                Destws.Range("AA" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng2, 12, 0)
                Destws.Range("AA:AA").NumberFormat = "dd-Mmm-yy"
                
                Destws.Range("AB" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng2, 13, 0)
                
            Next i
            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)
            
            For i = 2 To DestwslastRow
                
                Destws.Range("T" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng3, 12, 0)
                Destws.Range("T:T").NumberFormat = "dd-Mmm-yy"
                
                Destws.Range("U" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng3, 13, 0)
                
            Next i
            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)
            
            For i = 2 To DestwslastRow
                
                Destws.Range("J" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng4, 12, 0)
                Destws.Range("J:J").NumberFormat = "dd-Mmm-yy"
                
                Destws.Range("K" & i).Value = Application.WorksheetFunction.VLookup(Destws.Range("A" & i).Value, wsrng4, 13, 0)
                
            Next i
            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

Appreciate the help in advance!

[#2 · Accepted solution]

@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

[#3]

, somehow the Destwb was populated as 0, when search result (DC2, DC1, MISC and LOD1) is not found in Destwb after executing the code line by line.

[#4]

@hrh_dash 

I'd have to see the workbook...

[#5]

@Hans Vogelaar , i would like to insert an IFNA function together with the WITH FUNCTION.

i tried the following but no values were populated. Therefore, how can i insert the IFNA function?

        With Destws.Range("O2:O" & DestwslastRow)
        .NumberFormat = "dd-Mmm-yy"
        .Formula = "IFNA(VLOOKUP(A2," & wsrng.Address(External:=True) & ",7,FALSE),"")"
        .Value = .Value
        End With

[#6]

@hrh_dash 

A formula should begin with =, and quotes within a string should be doubled:

        .Formula = "=IFNA(VLOOKUP(A2," & wsrng.Address(External:=True) & ",7,FALSE),"""")"

[#7]

, thanks for the help! Can't believe i overlooked it..