• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to populate age buckets in a quicker way

ThrottleWorks

Excel Ninja
Hi,

I am populating 'Age buckets' using below mentioned code.
However it is taking time.
Can anyone please help me with quicker solution.

Usual time taken is around 4 minutes for 8,000+ rows.

Code:
Set TempRng = ItemsNotFoundSht.Range(ItemsNotFoundSht.Cells(2, 7), ItemsNotFoundSht.Cells(TempLr, 7))
    For Each TRng In TempRng
        If ItemsNotFoundSht.Cells(TRng.Row, 1) = "Consider" Then
            If ItemsNotFoundSht.Cells(TRng.Row, 3) = "" Then
                If TRng.Value < MapSht.Range("E3") Then
                    ItemsNotFoundSht.Cells(TRng.Row, 3) = MapSht.Range("D2") '0 to 5
                End If
                If TRng.Value > MapSht.Range("F2") Then
                    If TRng.Value < MapSht.Range("E4") Then
                        ItemsNotFoundSht.Cells(TRng.Row, 3) = MapSht.Range("D3") '6 to 10
                    End If
                End If
                If TRng.Value > MapSht.Range("F3") Then
                    If TRng.Value < MapSht.Range("E5") Then
                        ItemsNotFoundSht.Cells(TRng.Row, 3) = MapSht.Range("D4") '11 to 15
                    End If
                End If
                If TRng.Value > MapSht.Range("F4") Then
                    If TRng.Value <= MapSht.Range("E6") Then
                        ItemsNotFoundSht.Cells(TRng.Row, 3) = MapSht.Range("D5") '16 to 20
                    End If
                End If
                If TRng.Value > MapSht.Range("E6") Then
                    ItemsNotFoundSht.Cells(TRng.Row, 3) = MapSht.Range("D6") '>20 days
                End If
            End If
        End If
    Application.StatusBar = TempLr - TRng.Row
    Next TRng
 
The bottle neck is that you are looping through each cell and updating after each check...

Instead, load range to array and loop.

For result range, you can either "ReDim" array dimension before start of loop or you can use entire ItemsNotFounSht's data range as array.

Put it back to the sheet in one shot.

Alternately, this could be easily be done using PowerQuery.
 
With vba something like below.

Code:
Sub Demo()
Dim myArr, i As Long
myArr = Sheets("ItemsNotFound").UsedRange.Value
For i = 2 To UBound(myArr)
    If myArr(i, 1) = "Consider" Then
        Select Case myArr(i, 7)
            Case 0 To 5
                myArr(i, 3) = "0 to 5"
            Case 6 To 10
                myArr(i, 3) = "6 to 10"
            Case 11 To 15
                myArr(i, 3) = "11 to 15"
            Case 16 To 20
                myArr(i, 3) = "16 to 20"
            Case Else
                myArr(i, 3) = "Greater 20 days"
        End Select
    End If
Next

Sheets("ItemsNotFound").UsedRange = myArr

       
End Sub
 
Hi @Chihiro sir, thanks for the code.
However I am getting a bug while running this code.

Could you please help me if possible. It is not urgent.
Application defined or object defined error.

UBound is correct (1785)

Code is getting stuck at below line.
Sheets("ItemsNotFound").UsedRange = myArr

Code is able to transfer values till row 250 and post that it is generating bug.
 
If that's causing issue... it's likely that your workbook has oddity in used range and/or some other structure.

Tested on my end with 8k + records and had not issue with it.

Try this amendment to the code.
Code:
Sub Demo()
Dim myArr, i As Long
With Sheets("ItemsNotFound")
    myArr = .Range("A1:G" & .Cells(Rows.Count, "A").End(xlUp).Row).Value
End With
myArr = Sheets("ItemsNotFound").UsedRange.Value
For i = 2 To UBound(myArr)
    If myArr(i, 1) = "Consider" Then
        Select Case myArr(i, 7)
            Case 0 To 5
                myArr(i, 3) = "0 to 5"
            Case 6 To 10
                myArr(i, 3) = "6 to 10"
            Case 11 To 15
                myArr(i, 3) = "11 to 15"
            Case 16 To 20
                myArr(i, 3) = "16 to 20"
            Case Else
                myArr(i, 3) = "Greater 20 days"
        End Select
    End If
Next

Sheets("ItemsNotFound").Range("A1").Resize(UBound(myArr), 7) = myArr

End Sub
 

Attachments

  • Chandoo (1).xlsm
    117.5 KB · Views: 2
Back
Top