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
 
Sort by date Sort by votes
Flashbond said:
Surprising that it is slower than dealing with actual sheets and worksheet functions. Maybe it is better to use dictionaries. I am not that experienced with dictionaries. I can work for it or you can wait for another answer.
Click to expand...

Thanks for your help

I added in debug.print to post the time of each loop
and it is roughly iterating 10 per second

So the 4878 rows would take roughly 9 minutes

I have little experience with dictionaries also
 
Upvote 0

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.
I think this should be quite faster:
VBA Code: 
Sub test()
  Dim myRange2 As Variant, myRange3A As Object, myRange3B As Object, myRange4A As Object, myRange4B As Object, myRange4D As Object, myRange4E As Object
 
  myRange2 = Sheet2.Range("F4:L" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
  Set myRange3A = CreateObject("Scripting.dictionary")
  Set myRange3B = CreateObject("Scripting.dictionary")
  Set myRange4A = CreateObject("Scripting.dictionary")
  Set myRange4B = CreateObject("Scripting.dictionary")
  Set myRange4D = CreateObject("Scripting.dictionary")
  Set myRange4E = CreateObject("Scripting.dictionary")
    For i = 1 To Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
      myRange3A.Add Sheet3.Cells(i, "A").Value, i - 1
      myRange3B.Add Sheet3.Cells(i, "B").Value, i - 1
    Next
    For i = 1 To Sheet4.Cells(Rows.Count, "A").End(xlUp).Row
      myRange4A.Add Sheet4.Cells(i, "A").Value, i - 1
      myRange4B.Add Sheet4.Cells(i, "B").Value, i - 1
      myRange4D.Add Sheet4.Cells(i, "D").Value, i - 1
      myRange4E.Add Sheet4.Cells(i, "E").Value, i - 1
    Next
    
    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
        If myRange3A.Exists(ItemCode) Then
          SKU = myRange3B.Keys()(myRange3A(ItemCode))
        Else
          GoTo Continue
        End If
'Get ItemStatus from SKU
        If myRange4D.Exists(SKU) Then
          ItemStatus = myRange4E.Keys()(myRange4D(SKU))
        End If
        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
        If myRange4A.Exists(SKU) Then
          CurrentStock = myRange4B.Keys()(myRange4A(SKU))
        End If
        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
Flashbond said:
I think this should be quite faster:
VBA Code: 
Sub test()
  Dim myRange2 As Variant, myRange3A As Object, myRange3B As Object, myRange4A As Object, myRange4B As Object, myRange4D As Object, myRange4E As Object
 
  myRange2 = Sheet2.Range("F4:L" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
  Set myRange3A = CreateObject("Scripting.dictionary")
  Set myRange3B = CreateObject("Scripting.dictionary")
  Set myRange4A = CreateObject("Scripting.dictionary")
  Set myRange4B = CreateObject("Scripting.dictionary")
  Set myRange4D = CreateObject("Scripting.dictionary")
  Set myRange4E = CreateObject("Scripting.dictionary")
    For i = 1 To Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
      myRange3A.Add Sheet3.Cells(i, "A").Value, i - 1
      myRange3B.Add Sheet3.Cells(i, "B").Value, i - 1
    Next
    For i = 1 To Sheet4.Cells(Rows.Count, "A").End(xlUp).Row
      myRange4A.Add Sheet4.Cells(i, "A").Value, i - 1
      myRange4B.Add Sheet4.Cells(i, "B").Value, i - 1
      myRange4D.Add Sheet4.Cells(i, "D").Value, i - 1
      myRange4E.Add Sheet4.Cells(i, "E").Value, i - 1
    Next
  
    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
        If myRange3A.Exists(ItemCode) Then
          SKU = myRange3B.Keys()(myRange3A(ItemCode))
        Else
          GoTo Continue
        End If
'Get ItemStatus from SKU
        If myRange4D.Exists(SKU) Then
          ItemStatus = myRange4E.Keys()(myRange4D(SKU))
        End If
        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
        If myRange4A.Exists(SKU) Then
          CurrentStock = myRange4B.Keys()(myRange4A(SKU))
        End If
        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
Click to expand...

Thank you,
I had got the 9 minute time down to 5 by looking up the values like this but its still not quick enough:

VBA Code: 
        Set SKU_Find = Sheet3.Columns(1).Find(What:=ItemCode, After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If SKU_Find Is Nothing Then GoTo Continue Else SKU = SKU_Find.Offset(0, 1)

I have tried yours but it fails here
1682203506225.png


1682203522942.png


I expect this is due to "duplicates in Sheet3 - Column B

"ItemCode" is unique
but there is on occasion multiple SKUs per ItemCode

not sure how you would deal with that in dicts

I removed duplicates from SKU then it fails here
1682203893143.png


at the ItemStatus which also has many the same
 
Upvote 0
Keeping just the unique dictionaries, down to 2 minutes
So a step in the right direction

VBA Code: 
Sub test2()
Debug.Print Now
  Dim myRange2 As Variant, myRange3A As Object, myRange3B As Object, myRange4A As Object, myRange4B As Object, myRange4D As Object, myRange4E As Object
 
  myRange2 = Sheet2.Range("F4:L" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
  Set myRange3A = CreateObject("Scripting.dictionary")
  'Set myRange3B = CreateObject("Scripting.dictionary")
  Set myRange4A = CreateObject("Scripting.dictionary")
  'Set myRange4B = CreateObject("Scripting.dictionary")
  Set myRange4D = CreateObject("Scripting.dictionary")
  'Set myRange4E = CreateObject("Scripting.dictionary")
    For i = 1 To Sheet3.Cells(Rows.Count, "A").End(xlUp).Row
      myRange3A.Add Sheet3.Cells(i, "A").Value, i - 1
    Next
    For i = 1 To Sheet4.Cells(Rows.Count, "A").End(xlUp).Row
      myRange4A.Add Sheet4.Cells(i, "A").Value, i - 1
      myRange4D.Add Sheet4.Cells(i, "D").Value, i - 1

    Next
    
    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
        If myRange3A.Exists(ItemCode) Then
            Set SKU_Find = Sheet3.Columns(1).Find(What:=ItemCode, After:=Sheet3.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If SKU_Find Is Nothing Then GoTo Continue Else SKU = SKU_Find.Offset(0, 1)
        Else
          GoTo Continue
        End If
'Get ItemStatus from SKU
        If myRange4D.Exists(SKU) Then
            Set ItemStatus_Find = Sheet4.Columns(4).Find(What:=SKU, After:=Sheet4.Cells(1, 4), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If ItemStatus_Find Is Nothing Then ItemStatus = "" Else ItemStatus = ItemStatus_Find.Offset(0, 1)
        Else
            ItemStatus = ""
        End If
        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
        If myRange4A.Exists(SKU) Then
            Set CurrentStock_Find = Sheet4.Columns(1).Find(What:=SKU, After:=Sheet4.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
            If CurrentStock_Find Is Nothing Then CurrentStock = 0 Else CurrentStock = CurrentStock_Find.Offset(0, 1)
        Else
            CurrentStock = 0
        End If
        
        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
    
    Debug.Print Now
End Sub
 
Upvote 0
With some helper columns containing xlookup formulas before running the loop,
this now finishes in 2 seconds :)

VBA Code: 
Sub test2()
Debug.Print Now
  Dim myRange2 As Variant
 
   
    LR = Sheet2.Range("A65000").End(xlUp).Row
    Sheet2.Range("M4:M" & LR).FormulaR1C1 = "=XLOOKUP(RC[-7],ASINs!C[-12],ASINs!C[-11],"""")" 'Get SKU from ItemCode
    Sheet2.Range("N4:N" & LR).FormulaR1C1 = "=XLOOKUP(RC[-1],M3Data!C[-10],M3Data!C[-9],"""")" 'Get Status from SKU
    Sheet2.Range("O4:O" & LR).FormulaR1C1 = "=XLOOKUP(RC[-2],M3Data!C[-14],M3Data!C[-13],"""")" 'Get Current Stock from SKU
    Sheet2.Range("M4:O" & LR).Value2 = Sheet2.Range("M4:O" & LR).Value2
   
    myRange2 = Sheet2.Range("F4:O" & Sheet2.Cells(Rows.Count, "A").End(xlUp).Row)
   
    For i = 1 To UBound(myRange2)
        ItemCode = myRange2(i, 1)
        CurrentAvail = myRange2(i, 3)
        SKU = myRange2(i, 8)
        ItemStatus = myRange2(i, 9)
        CurrentStock = myRange2(i, 10)
       
        If CurrentAvail = "Permanently unavailable" Then GoTo Continue
        If SKU = "" Then GoTo Continue
       
        If CurrentAvail <> "Permanently unavailable" And ItemStatus <> "" Then
            myRange2(i, 5) = "Permanently unavailable"
            myRange2(i, 6) = Format(Date + 1, "YYYY/MM/DD")
        GoTo Continue
        End If
       
       
        If CurrentAvail = "Available" And CurrentStock > 0 Then GoTo Continue
 
        If CurrentAvail = "Available" And CurrentStock = "" 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 = "" 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
   
    Debug.Print Now

End Sub
 
Upvote 0
Hello @JumboCactuar:

I show you how it works with dictionaries. In the dictionary you put the key and store a data.
It is like the xlookup you search in column A and you get a data from column B.
Similarly, you store in an index the values of column A and each index you put the data of column B.

Other recommendations:
  • It is not good practice to use the GoTo statement.
  • In the following code I show you an alternative with Case statement to verify the conditions and accept one of them, without the need to jump with GoTo.
  • I also found another problem in your code, you use this variable CurrentSOH, but it was never filled (You can find it at the end of the Case).
  • I recommend using the Option Explicit statement at the beginning of your code, it forces you to declare all your variables but helps you check which one is missing or misspelled, among other things.
Try the following code, maybe something needs to be fine tuned, since I don't have data to test, only simulation data.

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)
    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 CurrentSOH = ""
           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


--------------
Let me know the result and I'll get back to you as soon as I can.
Sincerely
Dante Amor
--------------
 
Upvote 0
@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
You must log in or register to reply here.

Similar threads

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

Forum statistics

Threads
1,215,261
Messages
6,123,945
Members
449,134
Latest member
NickWBA

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