How would you speed up this loop

J

JumboCactuar

Well-known Member
Joined
Nov 16, 2016
Messages
785
Office Version
  1. 365
Platform
  1. Windows
Hi,
I wrote this loop and if the Last Row(LR) is quite large (1000+) it is slow to process.
I am guessing due to the xlookups in using, can anyone suggest anything to speed that up

Maybe it would help loading the lookup ranges into an array and search that?

thank you

VBA Code: 
LR = Sheet2.Range("A50000").End(xlUp).Row
    For i = 4 To LR
   
        ItemCode = Sheet2.Range("F" & i)
        CurrentAvail = Sheet2.Range("H" & i)
        If CurrentAvail = "Permanently unavailable" Then GoTo Continue
       
'Get SKU from ItemCode
        SKU = Application.WorksheetFunction.XLookup(ItemCode, Sheet3.Range("A:A"), Sheet3.Range("B:B"), "")
        If SKU = "" Then GoTo Continue
               
'Get ItemStatus from SKU
        ItemStatus = Application.WorksheetFunction.XLookup(SKU, Sheet4.Range("D:D"), Sheet4.Range("E:E"), "")
        If ItemStatus = "80" Or ItemStatus = "90" Then
            Sheet2.Range("J" & i) = "Permanently unavailable"
            Sheet2.Range("K" & i) = Format(Date + 1, "YYYY/MM/DD")
            GoTo Continue
        End If
       
'Get Current Stock available from SKU
        CurrentStock = Application.WorksheetFunction.XLookup(SKU, Sheet4.Range("A:A"), Sheet4.Range("B:B"), 0)

        If CurrentAvail = "Available" And CurrentStock > 0 Then GoTo Continue
        
        If CurrentAvail = "Available" And CurrentStock = 0 Then
            Sheet2.Range("J" & i) = "Temporarily unavailable"
            Sheet2.Range("K" & i) = Format(Date + 1, "YYYY/MM/DD")
            Sheet2.Range("L" & i) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
       
        If CurrentAvail = "Temporarily unavailable" And CurrentStock > 0 Then
            Sheet2.Range("J" & i) = "Available"
            GoTo Continue
        End If
       
        If CurrentAvail = "Temporarily unavailable" And CurrentSOH = 0 Then
            Sheet2.Range("J" & i) = "Temporarily unavailable"
            Sheet2.Range("L" & i) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
       
Continue:
    Next i
 

Excel Facts

Will the fill handle fill 1, 2, 3?
Yes! Type 1 in a cell. Hold down Ctrl while you drag the fill handle.
Sort by date Sort by votes
@DanteAmor
Thank you :) This is almost instant

I did change a couple of things in here
The CurrentSOH variable should be CurrentStock
CurrentStock and ItemStatus was retaining the current value for the next iteration if dic4a.exists(Sku) was false

VBA Code: 
Sub UsingDictionaryAndArrays()
  Dim dic3a As Object, dic4a As Object, dic4d As Object
  Dim ItemCode, CurrentAvail, Sku, ItemStatus, CurrentStock, CurrentSOH
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long
 
  Set dic3a = CreateObject("Scripting.dictionary")
  Set dic4a = CreateObject("Scripting.dictionary")
  Set dic4d = CreateObject("Scripting.dictionary")
 
  b = Sheet3.Range("A1:B" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(b, 1)
    dic3a(b(i, 1)) = b(i, 2)  'Index column 1 (A). Store column 2 (B)
  Next
 
  c = Sheet4.Range("A1:E" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(c, 1)
    dic4a(c(i, 1)) = c(i, 2)  'Index column 1 (A). Store column 2 (B) CurStock
    dic4d(c(i, 4)) = c(i, 5)  'Index column 4 (D). Store column 5 (E) ItemStatus
  Next
 
  a = Sheet2.Range("F4:L" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(a, 1)
    ItemCode = a(i, 1)
    CurrentAvail = a(i, 3)
   CurrentStock = 0 'Added - JumboCactuar
    ItemStatus = "" 'Added - JumboCactuar
    If dic3a.exists(ItemCode) Then
      Sku = dic3a(ItemCode)
      If dic4a.exists(Sku) Then CurrentStock = dic4a(Sku)
      If dic4d.exists(Sku) Then ItemStatus = dic4d(Sku)
    End If
 
    Select Case True
      Case CurrentAvail = "Permanently unavailable" Or Sku = "" Or _
           (CurrentAvail = "Available" And CurrentStock > 0)
    
      Case CurrentAvail <> "Permanently unavailable" And ItemStatus <> ""
           a(i, 5) = "Permanently unavailable"
           a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
    
      Case CurrentAvail = "Available" And CurrentStock = ""
           a(i, 5) = "Temporarily unavailable"
           a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
           a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
 
      Case CurrentAvail = "Temporarily unavailable" And CurrentStock > 0
           a(i, 5) = "Available"
           a(i, 6) = ""
           a(i, 7) = ""
 
      Case CurrentAvail = "Temporarily unavailable" And CurrentStock = 0
           a(i, 5) = "Temporarily unavailable"
           a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
    End Select
  Next
  Sheet2.Range("F4").Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub
 
Upvote 1
JumboCactuar said:
CurrentStock and ItemStatus was retaining the current value for the next iteration if dic4a.exists(Sku) was false
Click to expand...
Good point, in that case Sku should also start with = ""
VBA Code: 
Sub UsingDictionaryAndArrays()
  Dim dic3a As Object, dic4a As Object, dic4d As Object
  Dim ItemCode, CurrentAvail, Sku, ItemStatus, CurrentStock
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long
 
  Set dic3a = CreateObject("Scripting.dictionary")
  Set dic4a = CreateObject("Scripting.dictionary")
  Set dic4d = CreateObject("Scripting.dictionary")
  
  b = Sheet3.Range("A1:B" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(b, 1)
    dic3a(b(i, 1)) = b(i, 2)  'Index column 1 (A). Store column 2 (B)
  Next
  
  c = Sheet4.Range("A1:E" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(c, 1)
    dic4a(c(i, 1)) = c(i, 2)  'Index column 1 (A). Store column 2 (B) CurStock
    dic4d(c(i, 4)) = c(i, 5)  'Index column 4 (D). Store column 5 (E) ItemStatus
  Next
    
  a = Sheet2.Range("F4:L" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(a, 1)
    ItemCode = a(i, 1)
    CurrentAvail = a(i, 3)
    Sku = ""
    CurrentStock = 0
    ItemStatus = ""
    If dic3a.exists(ItemCode) Then
      Sku = dic3a(ItemCode)
      If dic4a.exists(Sku) Then CurrentStock = dic4a(Sku)
      If dic4d.exists(Sku) Then ItemStatus = dic4d(Sku)
    End If
  
    Select Case True
      Case CurrentAvail = "Permanently unavailable" Or Sku = "" Or _
           (CurrentAvail = "Available" And CurrentStock > 0)
       
      Case CurrentAvail <> "Permanently unavailable" And ItemStatus <> ""
           a(i, 5) = "Permanently unavailable"
           a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
       
      Case CurrentAvail = "Available" And CurrentStock = ""
           a(i, 5) = "Temporarily unavailable"
           a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
           a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
 
      Case CurrentAvail = "Temporarily unavailable" And CurrentStock > 0
           a(i, 5) = "Available"
 
      Case CurrentAvail = "Temporarily unavailable" And CurrentStock = 0
           a(i, 5) = "Temporarily unavailable"
           a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
    End Select
  Next
  Sheet2.Range("F4").Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

But if Sku = "" then the condition should enclose the whole process, that helps us in the process since if Sku = "" it is no longer necessary to enter to verify the CASE:
Rich (BB code): 
Sub UsingDictionaryAndArrays_v2()
  Dim dic3a As Object, dic4a As Object, dic4d As Object
  Dim ItemCode, CurrentAvail, Sku, ItemStatus, CurrentStock
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long
 
  Set dic3a = CreateObject("Scripting.dictionary")
  Set dic4a = CreateObject("Scripting.dictionary")
  Set dic4d = CreateObject("Scripting.dictionary")
      
  b = Sheet3.Range("A1:B" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(b, 1)
    dic3a(b(i, 1)) = b(i, 2)  'Index column 1 (A). Store column 2 (B)
  Next
  
  c = Sheet4.Range("A1:E" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(c, 1)
    dic4a(c(i, 1)) = c(i, 2)  'Index column 1 (A). Store column 2 (B) CurStock
    dic4d(c(i, 4)) = c(i, 5)  'Index column 4 (D). Store column 5 (E) ItemStatus
  Next
    
  a = Sheet2.Range("F4:L" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(a, 1)
    ItemCode = a(i, 1)
    CurrentAvail = a(i, 3)
    CurrentStock = 0
    ItemStatus = ""
    If dic3a.exists(ItemCode) Then
      Sku = dic3a(ItemCode)
      If dic4a.exists(Sku) Then CurrentStock = dic4a(Sku)
      If dic4d.exists(Sku) Then ItemStatus = dic4d(Sku)
  
      Select Case True
        Case CurrentAvail = "Permanently unavailable" Or Sku = "" Or _
             (CurrentAvail = "Available" And CurrentStock > 0)
         
        Case CurrentAvail <> "Permanently unavailable" And ItemStatus <> ""
             a(i, 5) = "Permanently unavailable"
             a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
         
        Case CurrentAvail = "Available" And CurrentStock = ""
             a(i, 5) = "Temporarily unavailable"
             a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
             a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
        
        Case CurrentAvail = "Temporarily unavailable" And CurrentStock > 0
             a(i, 5) = "Available"
        
        Case CurrentAvail = "Temporarily unavailable" And CurrentStock = 0
             a(i, 5) = "Temporarily unavailable"
             a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
      End Select
    End If
  Next
  Sheet2.Range("F4").Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

I hope the recommendations help in your process.
Sincerely
Dante Amor
--------------
 
Upvote 1
Solution
DanteAmor said:
Good point, in that case Sku should also start with = ""
VBA Code: 
Sub UsingDictionaryAndArrays()
  Dim dic3a As Object, dic4a As Object, dic4d As Object
  Dim ItemCode, CurrentAvail, Sku, ItemStatus, CurrentStock
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long
 
  Set dic3a = CreateObject("Scripting.dictionary")
  Set dic4a = CreateObject("Scripting.dictionary")
  Set dic4d = CreateObject("Scripting.dictionary")
 
  b = Sheet3.Range("A1:B" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(b, 1)
    dic3a(b(i, 1)) = b(i, 2)  'Index column 1 (A). Store column 2 (B)
  Next
 
  c = Sheet4.Range("A1:E" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(c, 1)
    dic4a(c(i, 1)) = c(i, 2)  'Index column 1 (A). Store column 2 (B) CurStock
    dic4d(c(i, 4)) = c(i, 5)  'Index column 4 (D). Store column 5 (E) ItemStatus
  Next
   
  a = Sheet2.Range("F4:L" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(a, 1)
    ItemCode = a(i, 1)
    CurrentAvail = a(i, 3)
    Sku = ""
    CurrentStock = 0
    ItemStatus = ""
    If dic3a.exists(ItemCode) Then
      Sku = dic3a(ItemCode)
      If dic4a.exists(Sku) Then CurrentStock = dic4a(Sku)
      If dic4d.exists(Sku) Then ItemStatus = dic4d(Sku)
    End If
 
    Select Case True
      Case CurrentAvail = "Permanently unavailable" Or Sku = "" Or _
           (CurrentAvail = "Available" And CurrentStock > 0)
      
      Case CurrentAvail <> "Permanently unavailable" And ItemStatus <> ""
           a(i, 5) = "Permanently unavailable"
           a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
      
      Case CurrentAvail = "Available" And CurrentStock = ""
           a(i, 5) = "Temporarily unavailable"
           a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
           a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
 
      Case CurrentAvail = "Temporarily unavailable" And CurrentStock > 0
           a(i, 5) = "Available"
 
      Case CurrentAvail = "Temporarily unavailable" And CurrentStock = 0
           a(i, 5) = "Temporarily unavailable"
           a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
    End Select
  Next
  Sheet2.Range("F4").Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

But if Sku = "" then the condition should enclose the whole process, that helps us in the process since if Sku = "" it is no longer necessary to enter to verify the CASE:
Rich (BB code): 
Sub UsingDictionaryAndArrays_v2()
  Dim dic3a As Object, dic4a As Object, dic4d As Object
  Dim ItemCode, CurrentAvail, Sku, ItemStatus, CurrentStock
  Dim a As Variant, b As Variant, c As Variant
  Dim i As Long
 
  Set dic3a = CreateObject("Scripting.dictionary")
  Set dic4a = CreateObject("Scripting.dictionary")
  Set dic4d = CreateObject("Scripting.dictionary")
     
  b = Sheet3.Range("A1:B" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(b, 1)
    dic3a(b(i, 1)) = b(i, 2)  'Index column 1 (A). Store column 2 (B)
  Next
 
  c = Sheet4.Range("A1:E" & Sheet3.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(c, 1)
    dic4a(c(i, 1)) = c(i, 2)  'Index column 1 (A). Store column 2 (B) CurStock
    dic4d(c(i, 4)) = c(i, 5)  'Index column 4 (D). Store column 5 (E) ItemStatus
  Next
   
  a = Sheet2.Range("F4:L" & Sheet2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  For i = 1 To UBound(a, 1)
    ItemCode = a(i, 1)
    CurrentAvail = a(i, 3)
    CurrentStock = 0
    ItemStatus = ""
    If dic3a.exists(ItemCode) Then
      Sku = dic3a(ItemCode)
      If dic4a.exists(Sku) Then CurrentStock = dic4a(Sku)
      If dic4d.exists(Sku) Then ItemStatus = dic4d(Sku)
 
      Select Case True
        Case CurrentAvail = "Permanently unavailable" Or Sku = "" Or _
             (CurrentAvail = "Available" And CurrentStock > 0)
        
        Case CurrentAvail <> "Permanently unavailable" And ItemStatus <> ""
             a(i, 5) = "Permanently unavailable"
             a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
        
        Case CurrentAvail = "Available" And CurrentStock = ""
             a(i, 5) = "Temporarily unavailable"
             a(i, 6) = Format(Date + 1, "YYYY/MM/DD")
             a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
       
        Case CurrentAvail = "Temporarily unavailable" And CurrentStock > 0
             a(i, 5) = "Available"
       
        Case CurrentAvail = "Temporarily unavailable" And CurrentStock = 0
             a(i, 5) = "Temporarily unavailable"
             a(i, 7) = Format(Date + 31, "YYYY/MM/DD")
      End Select
    End If
  Next
  Sheet2.Range("F4").Resize(UBound(a, 1), UBound(a, 2)) = a
End Sub

I hope the recommendations help in your process.
Sincerely
Dante Amor
--------------
Click to expand...

@DanteAmor
Thank you, forgot about the SKU

Confirmed working as expected, and I understand how these dictionaries work now
 
Upvote 1
One small contribution from me. If I am not wrong, you may get away without "If" checks, since the dictionaries return empty if the key is not found. Because you are selecting each case if they are empty or not later, it must be safe to do this:
VBA Code: 
    If dic3a.exists(ItemCode) Then
      Sku = dic3a(ItemCode)
      If dic4a.exists(Sku) Then CurrentStock = dic4a(Sku)
      If dic4d.exists(Sku) Then ItemStatus = dic4d(Sku)
    End If
To:
VBA Code: 
      Sku = dic3a(ItemCode)
      CurrentStock = dic4a(Sku)
      ItemStatus = dic4d(Sku)

OR, alternative the to above, maybe ternary expressions even possible at this point:
VBA Code: 
    ItemCode = a(i, 1)
    CurrentAvail = a(i, 3)
    Sku = IIf(dic3a.exists(ItemCode), dic3a(ItemCode),"")
    CurrentStock = IIf(dic4a.exists(Sku), dic4a(Sku),0)
    ItemStatus = IIf(dic4d.exists(Sku), dic4d(Sku),"")

Btw, I am blown away the logic processing of @DanteAmor
 
Upvote 1
I would use the .End(xlUp).Row on the dataset page lookup columns or use tables and calculations to do all of the above . . .
 
Upvote 0
CSmith said:
I would use the .End(xlUp).Row on the dataset page lookup columns or use tables and calculations to do all of the above . . .
Click to expand...

Not sure how i would do that with this.

I thought about writing the sheet data to arrays
then lookup the ItemCode but not sure how lookups work in arrays
 
Upvote 0
It is very hard to say without the actual data but this should work:
VBA Code: 
Sub test()
  Dim myRange2 As Variant, myRange3 As Variant, myRange4 As Variant
 
  myRange2 = Sheet2.Range("F4:L" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
  myRange3 = Intersect(Sheet3.UsedRange, Sheet3.Range("A:B"))
  myRange4 = Intersect(Sheet4.UsedRange, Sheet4.Range("A:E"))
 
    For i = 1 To UBound(myRange2)
        ItemCode = myRange2(i, 1)
        CurrentAvail = myRange2(i, 3)
        If CurrentAvail = "Permanently unavailable" Then GoTo Continue
     
'Get SKU from ItemCode
        SKU = Application.WorksheetFunction.XLookup(ItemCode, myRange3.Columns(1), myRange3.Columns(2), "")
        If SKU = "" Then GoTo Continue
             
'Get ItemStatus from SKU
        ItemStatus = Application.WorksheetFunction.XLookup(SKU, myRange4.Columns(4), myRange4.Columns(5), "")
        If ItemStatus = "80" Or ItemStatus = "90" Then
            myRange2(i, 5) = "Permanently unavailable"
            myRange2(i, 6) = Format(Date + 1, "YYYY/MM/DD")
            GoTo Continue
        End If
     
'Get Current Stock available from SKU
        CurrentStock = Application.WorksheetFunction.XLookup(SKU, myRange4.Columns(1), myRange4.Columns(2), 0)

        If CurrentAvail = "Available" And CurrentStock > 0 Then GoTo Continue
      
        If CurrentAvail = "Available" And CurrentStock = 0 Then
            myRange2(i, 5) = "Temporarily unavailable"
            myRange2(i, 6) = Format(Date + 1, "YYYY/MM/DD")
            myRange2(i, 7) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
     
        If CurrentAvail = "Temporarily unavailable" And CurrentStock > 0 Then
            myRange2(i, 5) = "Available"
            GoTo Continue
        End If
     
        If CurrentAvail = "Temporarily unavailable" And CurrentSOH = 0 Then
            myRange2(i, 5) = "Temporarily unavailable"
            myRange2(i, 7) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
     
Continue:
    Next i
    Sheet2.Range("F4").Resize(UBound(myRange2), UBound(myRange2, 2)) = myRange2
End Sub
 
Upvote 0
the really fast way to do this is to use the Dictionary object instead of all the XLOOKUP . I was slightluy puzzled as to why you are looking up SKU in two different columns on shet4, That just doesn't mnake sense to me. SO I left that one!!
this is untested but should be super fast!!

VBA Code: 
Sub test()
lr = Sheet2.Range("A50000").End(xlUp).Row
'  add all the next few lines of code
inarr = Range(Cells(1, 1), Cells(lr, 8)) ' load all of the data columns A to H into an array
' load data from sheet 2 into a dictionary
With Worksheets("Sheet3")
lr3 = .Cells(Rows.Count, "A").End(xlUp).Row
in3 = .Range(.Cells(1, 1), .Cells(lr3, 2))
Dim Dic3 As Object
Set Dic3 = CreateObject("Scripting.dictionary")
For j = 1 To lr3
        Dic3(in3(i, 1)) = in3(i, 2)               ' Load Dictionary with Value in Column B
Next j
End With
 
With Worksheets("Sheet4")
lr4 = .Cells(Rows.Count, "A").End(xlUp).Row
in4 = .Range(.Cells(1, 1), .Cells(lr4, 5))  ' load columns at to E
Dim Dic4 As Object
Set Dic4 = CreateObject("Scripting.dictionary")
For j = 1 To lr4
        Dic4(in4(i, 1)) = in4(i, 2)               ' Load Dictionary with index into array in4 becaue we need to use it twice ( Note I didn't do this, see comment)
Next j
End With
 
' Now the re written part
 
 
 
    For i = 4 To lr
 
'        ItemCode = Sheet2.Range("F" & i)
'        CurrentAvail = Sheet2.Range("H" & i)
        ItemCode = inarr(i, 6)
        CurrentAvail = inarr(i, 8)
        If CurrentAvail = "Permanently unavailable" Then GoTo Continue
'Get SKU from ItemCode
   
  '      SKU = Application.WorksheetFunction.XLookup(ItemCode, Sheet3.Range("A:A"), Sheet3.Range("B:B"), "")
         If Dic3.Exists(inarr(i, 1)) Then  ' check if element exists
         SKU = Dic3(inarr(i, 1)) ' Load output with dictionary value
         Else          ' if it not set to not found
         GoTo Continue
         End If
  
 '       If SKU = "" Then GoTo Continue
          
'Get ItemStatus from SKU
        ItemStatus = Application.WorksheetFunction.XLookup(SKU, Sheet4.Range("D:D"), Sheet4.Range("E:E"), "")
  ' slightly puzzled by this one because you seem to belooking up SKU  in column D as well as column A below, is this correct or necessary,
  ' becuase it would require loading another dictionary
   
        If ItemStatus = "80" Or ItemStatus = "90" Then
            Sheet2.Range("J" & i) = "Permanently unavailable"
            Sheet2.Range("K" & i) = Format(Date + 1, "YYYY/MM/DD")
            GoTo Continue
        End If
  
'Get Current Stock available from SKU
'        CurrentStock = Application.WorksheetFunction.XLookup(SKU, Sheet4.Range("A:A"), Sheet4.Range("B:B"), 0)
         If Dic4.Exists(SKU) Then  ' check if element exists
         CurrentStock = Dic4(SKU) ' Load output with dictionary value
         End If

        If CurrentAvail = "Available" And CurrentStock > 0 Then GoTo Continue
   
        If CurrentAvail = "Available" And CurrentStock = 0 Then
            Sheet2.Range("J" & i) = "Temporarily unavailable"
            Sheet2.Range("K" & i) = Format(Date + 1, "YYYY/MM/DD")
            Sheet2.Range("L" & i) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
  
        If CurrentAvail = "Temporarily unavailable" And CurrentStock > 0 Then
            Sheet2.Range("J" & i) = "Available"
            GoTo Continue
        End If
  
        If CurrentAvail = "Temporarily unavailable" And CurrentSOH = 0 Then
            Sheet2.Range("J" & i) = "Temporarily unavailable"
            Sheet2.Range("L" & i) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
  
Continue:
    Next i

End Sub
Note you could combine this with the solution from flashbond to get the benefit from both solutions
 
Last edited:
Upvote 0
offthelip said:
the really fast way to do this is to use the Dictionary object instead of all the XLOOKUP . I was slightluy puzzled as to why you are looking up SKU in two different columns on shet4, That just doesn't mnake sense to me. SO I left that one!!
this is untested but should be super fast!!

VBA Code: 
Sub test()
lr = Sheet2.Range("A50000").End(xlUp).Row
'  add all the next few lines of code
inarr = Range(Cells(1, 1), Cells(lr, 8)) ' load all of the data columns A to H into an array
' load data from sheet 2 into a dictionary
With Worksheets("Sheet3")
lr3 = .Cells(Rows.Count, "A").End(xlUp).Row
in3 = .Range(.Cells(1, 1), .Cells(lr3, 2))
Dim Dic3 As Object
Set Dic3 = CreateObject("Scripting.dictionary")
For j = 1 To lr3
        Dic3(in3(i, 1)) = in3(i, 2)               ' Load Dictionary with Value in Column B
Next j
End With
 
With Worksheets("Sheet4")
lr4 = .Cells(Rows.Count, "A").End(xlUp).Row
in4 = .Range(.Cells(1, 1), .Cells(lr4, 5))  ' load columns at to E
Dim Dic4 As Object
Set Dic4 = CreateObject("Scripting.dictionary")
For j = 1 To lr4
        Dic4(in4(i, 1)) = in4(i, 2)               ' Load Dictionary with index into array in4 becaue we need to use it twice ( Note I didn't do this, see comment)
Next j
End With
 
' Now the re written part
 
 
 
    For i = 4 To lr
 
'        ItemCode = Sheet2.Range("F" & i)
'        CurrentAvail = Sheet2.Range("H" & i)
        ItemCode = inarr(i, 6)
        CurrentAvail = inarr(i, 8)
        If CurrentAvail = "Permanently unavailable" Then GoTo Continue
'Get SKU from ItemCode
  
  '      SKU = Application.WorksheetFunction.XLookup(ItemCode, Sheet3.Range("A:A"), Sheet3.Range("B:B"), "")
         If Dic3.Exists(inarr(i, 1)) Then  ' check if element exists
         SKU = Dic3(inarr(i, 1)) ' Load output with dictionary value
         Else          ' if it not set to not found
         GoTo Continue
         End If
 
 '       If SKU = "" Then GoTo Continue
         
'Get ItemStatus from SKU
        ItemStatus = Application.WorksheetFunction.XLookup(SKU, Sheet4.Range("D:D"), Sheet4.Range("E:E"), "")
  ' slightly puzzled by this one because you seem to belooking up SKU  in column D as well as column A below, is this correct or necessary,
  ' becuase it would require loading another dictionary
  
        If ItemStatus = "80" Or ItemStatus = "90" Then
            Sheet2.Range("J" & i) = "Permanently unavailable"
            Sheet2.Range("K" & i) = Format(Date + 1, "YYYY/MM/DD")
            GoTo Continue
        End If
 
'Get Current Stock available from SKU
'        CurrentStock = Application.WorksheetFunction.XLookup(SKU, Sheet4.Range("A:A"), Sheet4.Range("B:B"), 0)
         If Dic4.Exists(SKU) Then  ' check if element exists
         CurrentStock = Dic4(SKU) ' Load output with dictionary value
         End If

        If CurrentAvail = "Available" And CurrentStock > 0 Then GoTo Continue
  
        If CurrentAvail = "Available" And CurrentStock = 0 Then
            Sheet2.Range("J" & i) = "Temporarily unavailable"
            Sheet2.Range("K" & i) = Format(Date + 1, "YYYY/MM/DD")
            Sheet2.Range("L" & i) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
 
        If CurrentAvail = "Temporarily unavailable" And CurrentStock > 0 Then
            Sheet2.Range("J" & i) = "Available"
            GoTo Continue
        End If
 
        If CurrentAvail = "Temporarily unavailable" And CurrentSOH = 0 Then
            Sheet2.Range("J" & i) = "Temporarily unavailable"
            Sheet2.Range("L" & i) = Format(Date + 31, "YYYY/MM/DD")
            GoTo Continue
        End If
 
Continue:
    Next i

End Sub
Note you could combine this with the solution from flashbond to get the benefit from both solutions
Click to expand...

Thank you
Will give this a try

I was slightluy puzzled as to why you are looking up SKU in two different columns on shet4
Click to expand...

I have 2 sets of data on that sheet (Columns A + B) + (Columns D+E)
 
Upvote 0
You must log in or register to reply here.

Similar threads

Agnarr
  • Question
VBA problem with creating new sheets
Replies
0
Views
463
Agnarr
Agnarr
A
  • Question
how to add my signature with images to macro
Replies
1
Views
218
Domenic
D
E
  • Question
Trying to improve quality of image on Email.
Replies
0
Views
94
Eric Penfold
E
S
  • Solved
Miscrosoft has Blocking The Macro Sometimes and disabling the macros
Replies
5
Views
470
NdNoviceHlp
NdNoviceHlp
S
  • Question
Scan Attendance
Replies
1
Views
318
Stewart11715
S

Forum statistics

Threads
1,216,213
Messages
6,129,550
Members
449,516
Latest member
lukaderanged

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top