Make Code Faster

[adeel1]

Hello All

i have below code it is taking about 13 min for 211914 rows to perform activity which is huge time to wait, due to lounge restriction I am unable to upload file as it is 6MB
is there way to make this code fast about to 10 to 15 sec!
Adeel

Code: Select all

Sub jj()

Range("h:i").ClearContents
Range("h1:i2").Clear
Dim i As Long

w = 2
e = 2

For i = 2 To Cells(Rows.Count, 3).End(xlUp).Row
If Cells(i, 3) <> "" Then
Cells(w + 1, 8) = Cells(i, 3)
w = w + 1


ElseIf Cells(i, 4) <> "" Then
Cells(e + 1, 9) = Cells(i, 4)
e = e + 1

End If
Next i
Range("H2") = "=""Ttl Num "" &COUNTA(H3:H170000)"
Range("i2") = "=""Ttl Num "" &COUNTA(i3:i170000)"

'Below Are Reserved Numbers
Range("h1:i1").Font.Bold = True

Range("h1:i1").Interior.ColorIndex = 45
Range("h1") = "Below Are Reserved Numbers"

Range("i1") = "Non Reserved"

End Sub

[HansV]

Is this better?

Code: Select all

Sub jj()
    Dim i As Long
    Dim w As Long
    Dim e As Long
    Dim m As Long
    Dim v1() As Variant
    Dim v2() As Variant

    Application.ScreenUpdating = False

    Range("H:I").ClearContents
    Range("H1:I2").Clear

    m = Cells(Rows.Count, 3).End(xlUp).Row
    w = 2
    e = 2

    v1 = Range("C1:D" & m).Value
    v2 = Range("H1:I" & m).Value
    For i = 2 To m
        If v1(i, 1) <> "" Then
            w = w + 1
            v2(w, 1) = v1(i, 1)
        ElseIf v1(i, 2) <> "" Then
            e = e + 1
            v2(e, 2) = v1(i, 2)
        End If
    Next i

    v2(1, 1) = "Below Are Reserved Numbers"
    v2(1, 2) = "Non Reserved"
    Range("H1:I" & m).Value = v2

    Range("H1:I1").Font.Bold = True
    Range("H1:I1").Interior.ColorIndex = 45

    Range("H2").Formula = "=""Ttl Num "" &COUNTA(H3:H" & m & ")"
    Range("I2").Formula = "=""Ttl Num "" &COUNTA(I3:I" & m & ")"

    Application.ScreenUpdating = True
End Sub

[adeel1]

No its not better, its super fast, its took only 2 sec thnx
which loop this is called? array

Adeel

[HansV]

The main point is that the values of the ranges are loaded into two arrays: v1 for columns C and D, and v2 for columns H and I.
Looping through an array is much faster than looping through cells.

[adeel1]

thnx for this , please don't mind if I come back here to ask something more about it.

Adeel

[HansV]

Feel free to ask more questions.

[adeel1]

Hi, bit late here
for output to change below again and again isn't good idea how i can make it dynamic too
w = 2
e = 2
f = 2

i tried something like below but its limities my output to 5 rows
For i = 2 To m
For s = 2 To 5
then replace s with w,e,f

Code: Select all

Sub jj()
    Dim i As Long
    Dim w As Long
    Dim e As Long
    Dim m As Long
    Dim v1() As Variant
    Dim v2() As Variant

    Application.ScreenUpdating = False

    
    m = Cells(Rows.Count, 1).End(xlUp).Row
    w = 2
    e = 2
    f = 2
     v1 = Range("a1:a" & m).Value
     v2 = Range("b1:f" & m).Value
    For i = 2 To m
        If Left(v1(i, 1), 3) = 320 Then
            w = w + 1
            v2(w, 1) = v1(i, 1)
            
            ElseIf Left(v1(i, 1), 3) = 321 Then
            e = e + 1
            v2(e, 2) = v1(i, 1)
            
            ElseIf Left(v1(i, 1), 3) = 324 Then
            f = f + 1
            v2(f, 3) = v1(i, 1)
        
        End If
    Next i

    
    Range("b1:f" & m).Value = v2

   
    Application.ScreenUpdating = True
End Sub

Adeel

[HansV]

Can you explain what you want to do?

[adeel1]

sorry about my English as i am not,

for example i have multiple condition and with different columns output then i have to give/change each output by changing e and 2

e = e + 1
v2(e, 2) = v1(i, 1)

for second condition here is change of f and 3

f = f + 1
v2(f, 3) = v1(i, 1)
if i go for more output col i have to add and change e and f with other one letter and also need to change 2 and 3 to 4 manually.

Adeel

[HansV]

Try this. Modify the "???" as needed.

Code: Select all

Sub jj()
    Dim i As Long
    ' Columns B to F = 5 columns
    Dim r(1 To 5) As Long
    Dim c As Long
    Dim m As Long
    Dim v1() As Variant
    Dim v2() As Variant

    Application.ScreenUpdating = False

    For i = 1 To 5
        r(i) = 2
    Next i

    m = Cells(Rows.Count, 1).End(xlUp).Row
    v1 = Range("a1:a" & m).Value
    v2 = Range("b1:f" & m).Value

    For i = 2 To m
        Select Case Left(v1(i, 1), 3)
            Case "320"
                c = 1
            Case "321"
                c = 2
            Case "324"
                c = 3
            Case "???"
                c = 4
            Case "???"
                c = 5
            Case Else
                c = 0
        End Select
        If c > 0 Then
            r(c) = r(c) + 1
            v2(r(c), c) = v1(i, 1)
        End If
    Next i

    Range("b1:f" & m).Value = v2

    Application.ScreenUpdating = True
End Sub

[adeel1]

hmm, you change the idea/technique I was trying to learn with same code I thing that isn't possible with that let me understand this one, thnx

Adeel

[ErikJan]

The main point is that the values of the ranges are loaded into two arrays: v1 for columns C and D, and v2 for columns H and I.
Looping through an array is much faster than looping through cells.

Hans, just for my curiosity (and I admit I'm lazy as I could test this myself too) but I wonder where the biggest gain is... Is that really the case or is it the "ScreenUpdating" that does this?

[HansV]

I haven't benchmarked the code, but unboubtedly both contribute. However, processing an array is much faster than reading and writing cell values one by one.

[ErikJan]

Hans, I'm trying to setup a little test based on the code above. I think (...) I see that the original code writes to cells in the loop and yours does not (only to the array)... Am I missing something?

[HansV]

The line

Code: Select all

    Range("b1:f" & m).Value = v2

writes the array back to the range in one go.

[adeel1]

i am not sure may be this line is making main difference in code faster

Code: Select all

Range("b1:f" & m).Value = v2

if i use below idea this is also not faster than you posted

Code: Select all

Sub jj()

Dim arr() As Variant
Application.ScreenUpdating = False
m = Cells(Rows.Count, 1).End(xlUp).Row

ReDim arr(m)

For i = 1 To m

arr(i) = Cells(i, 1).Value

If Left(arr(i), 3) = 320 Then

Cells(o + 3, 2) = arr(i)
o = o + 1

End If
Next i
 Application.ScreenUpdating = True

End Sub

does these lines are alternative of redim as above code.

Code: Select all

v1 = Range("a1:a" & m).Value
     v2 = Range("b1:f" & m).Value

adeel

[ErikJan]

The line

Code: Select all

    Range("b1:f" & m).Value = v2

writes the array back to the range in one go.

Ah, yes. Thanks (sorry, my bad)

[HansV]

@Adeel: yes, the array assignments are the equivalent of redimensioning the arrays and filling them.

[adeel1]

it would be great learning, thnx sir