Help to make VBA code shorter

E

excel_beginer

New Member
Joined
Dec 28, 2017
Messages
19
Hi all
I have code below to check balansheet then copy row with conditions
But I thinks this code too long and run slow, could you make this code shorter

Many thank

Code: 
Sub CheckPS_noibang()Worksheets("result").Range("A20:Z15000").Clear
Application.ScreenUpdating = False
Dim i As Integer, lastrow As Integer, lastrownoibang As Integer
   lastrownoibang = Sheets("noibang").Range("B" & Rows.Count).End(xlUp).Row + 1
    For i = 2 To lastrownoibang
        lastrow = Sheets("Result").Cells(Rows.Count, 2).End(xlUp).Row
        With Sheets("noibang")
            If (Left(.Cells(i, 3), 1) = 5 Or Left(.Cells(i, 3), 1) = 6 Or Left(.Cells(i, 3), 2) = 47 Or Left(.Cells(i, 3), 3) = 486 Or .Cells(i, 3) = 20 Or .Cells(i, 3) = 21 Or .Cells(i, 3) = 22 Or .Cells(i, 3) = 23 Or .Cells(i, 3) = 24 Or .Cells(i, 3) = 25 Or .Cells(i, 3) = 26 Or .Cells(i, 3) = 27 Or .Cells(i, 3) = 28 Or .Cells(i, 3) = 29 Or .Cells(i, 3) = 30 Or .Cells(i, 3) = 48) And (.Cells(i, 4).Value - .Cells(i, 5).Value) + (.Cells(i, 6).Value - .Cells(i, 7).Value) <> (.Cells(i, 8).Value - .Cells(i, 9).Value) Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Rows(lastrow + 1))
            ElseIf (Left(.Cells(i, 3), 1) = 1 Or Left(.Cells(i, 3), 1) = 2 Or Left(.Cells(i, 3), 1) = 3 Or Left(.Cells(i, 3), 1) = 8) And (.Cells(i, 3) <> 12 And .Cells(i, 3) <> 13 And .Cells(i, 3) <> 14 And .Cells(i, 3) <> 15 And .Cells(i, 3) <> 16 And .Cells(i, 3) <> 20 And .Cells(i, 3) <> 21 And .Cells(i, 3) <> 22 And .Cells(i, 3) <> 23 And .Cells(i, 3) <> 24 And .Cells(i, 3) <> 25 And .Cells(i, 3) <> 26 And .Cells(i, 3) <> 27 And .Cells(i, 3) <> 28 And .Cells(i, 3) <> 29 And .Cells(i, 3) <> 30 And Left(.Cells(i, 3), 3) <> 149 And Left(.Cells(i, 3), 3) <> 159 And Left(.Cells(i, 3), 3) <> 169 And Left(.Cells(i, 3), 3) <> 209 And Left(.Cells(i, 3), 3) <> 219 And Left(.Cells(i, 3), 3) <> 229 And Left(.Cells(i, 3), 3) <> 239 And Left(.Cells(i, 3), 3) <> 249 And Left(.Cells(i, 3), 3) <> 259 And Left(.Cells(i, 3), 3) <> 269 And Left(.Cells(i, 3), 3) <> 279 And Left(.Cells(i, 3), 3) <> 289 And Left(.Cells(i, 3), 3) <> 299 And Left(.Cells(i, 3), 3) <> 305) Then
                If (.Cells(i, 4).Value + .Cells(i, 6).Value - .Cells(i, 7).Value) <> .Cells(i, 8).Value Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Range("A" & lastrow + 1))
                End If
            ElseIf (Left(.Cells(i, 3), 1) = 4 Or Left(.Cells(i, 3), 1) = 7 Or Left(.Cells(i, 3), 3) = 209 Or Left(.Cells(i, 3), 3) = 219 Or Left(.Cells(i, 3), 3) = 229 Or Left(.Cells(i, 3), 3) = 239 Or Left(.Cells(i, 3), 3) = 249 Or Left(.Cells(i, 3), 3) = 259 Or Left(.Cells(i, 3), 3) = 269 Or Left(.Cells(i, 3), 3) = 279 Or Left(.Cells(i, 3), 3) = 289 Or Left(.Cells(i, 3), 3) = 299 Or Left(.Cells(i, 3), 3) = 305) And ((Left(.Cells(i, 3), 2) <> 47) And (Left(.Cells(i, 3), 3) <> 486) And (.Cells(i, 3) <> 48) And (.Cells(i, 5).Value + .Cells(i, 7).Value - .Cells(i, 6).Value) <> .Cells(i, 9).Value) Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Rows(lastrow + 1))
            End If
       End With
    Next i
Application.ScreenUpdating = True
End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
excel_beginer said:
Hi all
I have code below to check balansheet then copy row with conditions
But I thinks this code too long and run slow, could you make this code shorter

Many thank

Code: 
Sub CheckPS_noibang()Worksheets("result").Range("A20:Z15000").Clear
Application.ScreenUpdating = False
Dim i As Integer, lastrow As Integer, lastrownoibang As Integer
   lastrownoibang = Sheets("noibang").Range("B" & Rows.Count).End(xlUp).Row + 1
    For i = 2 To lastrownoibang
        lastrow = Sheets("Result").Cells(Rows.Count, 2).End(xlUp).Row
        With Sheets("noibang")
            If (Left(.Cells(i, 3), 1) = 5 Or Left(.Cells(i, 3), 1) = 6 Or Left(.Cells(i, 3), 2) = 47 Or Left(.Cells(i, 3), 3) = 486 Or .Cells(i, 3) = 20 Or .Cells(i, 3) = 21 Or .Cells(i, 3) = 22 Or .Cells(i, 3) = 23 Or .Cells(i, 3) = 24 Or .Cells(i, 3) = 25 Or .Cells(i, 3) = 26 Or .Cells(i, 3) = 27 Or .Cells(i, 3) = 28 Or .Cells(i, 3) = 29 Or .Cells(i, 3) = 30 Or .Cells(i, 3) = 48) And (.Cells(i, 4).Value - .Cells(i, 5).Value) + (.Cells(i, 6).Value - .Cells(i, 7).Value) <> (.Cells(i, 8).Value - .Cells(i, 9).Value) Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Rows(lastrow + 1))
            ElseIf (Left(.Cells(i, 3), 1) = 1 Or Left(.Cells(i, 3), 1) = 2 Or Left(.Cells(i, 3), 1) = 3 Or Left(.Cells(i, 3), 1) = 8) And (.Cells(i, 3) <> 12 And .Cells(i, 3) <> 13 And .Cells(i, 3) <> 14 And .Cells(i, 3) <> 15 And .Cells(i, 3) <> 16 And .Cells(i, 3) <> 20 And .Cells(i, 3) <> 21 And .Cells(i, 3) <> 22 And .Cells(i, 3) <> 23 And .Cells(i, 3) <> 24 And .Cells(i, 3) <> 25 And .Cells(i, 3) <> 26 And .Cells(i, 3) <> 27 And .Cells(i, 3) <> 28 And .Cells(i, 3) <> 29 And .Cells(i, 3) <> 30 And Left(.Cells(i, 3), 3) <> 149 And Left(.Cells(i, 3), 3) <> 159 And Left(.Cells(i, 3), 3) <> 169 And Left(.Cells(i, 3), 3) <> 209 And Left(.Cells(i, 3), 3) <> 219 And Left(.Cells(i, 3), 3) <> 229 And Left(.Cells(i, 3), 3) <> 239 And Left(.Cells(i, 3), 3) <> 249 And Left(.Cells(i, 3), 3) <> 259 And Left(.Cells(i, 3), 3) <> 269 And Left(.Cells(i, 3), 3) <> 279 And Left(.Cells(i, 3), 3) <> 289 And Left(.Cells(i, 3), 3) <> 299 And Left(.Cells(i, 3), 3) <> 305) Then
                If (.Cells(i, 4).Value + .Cells(i, 6).Value - .Cells(i, 7).Value) <> .Cells(i, 8).Value Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Range("A" & lastrow + 1))
                End If
            ElseIf (Left(.Cells(i, 3), 1) = 4 Or Left(.Cells(i, 3), 1) = 7 Or Left(.Cells(i, 3), 3) = 209 Or Left(.Cells(i, 3), 3) = 219 Or Left(.Cells(i, 3), 3) = 229 Or Left(.Cells(i, 3), 3) = 239 Or Left(.Cells(i, 3), 3) = 249 Or Left(.Cells(i, 3), 3) = 259 Or Left(.Cells(i, 3), 3) = 269 Or Left(.Cells(i, 3), 3) = 279 Or Left(.Cells(i, 3), 3) = 289 Or Left(.Cells(i, 3), 3) = 299 Or Left(.Cells(i, 3), 3) = 305) And ((Left(.Cells(i, 3), 2) <> 47) And (Left(.Cells(i, 3), 3) <> 486) And (.Cells(i, 3) <> 48) And (.Cells(i, 5).Value + .Cells(i, 7).Value - .Cells(i, 6).Value) <> .Cells(i, 9).Value) Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Rows(lastrow + 1))
            End If
       End With
    Next i
Application.ScreenUpdating = True
End Sub
Click to expand...


Three things that I know that speed up vba code:
1. Application.ScreenUpdating - You already have this one
2. Application.Calculation = xlManual at the Start and Application.Calculation = xlAutomatic at the end of code (Using Application.Calculate when needed in the code)
3. Rewriting the code to NOT copy. Copy and Paste takes up memory and slows things down. Try instead to write (as an example) Worksheet("Sheet2").Range("A2:C2") = Worksheet("Sheet1").Range("D5:F5").Value
 
Upvote 0
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
here is your code rewritten using a single variant array to all the input checks, this iwll make it a lot faster. (NOTE: untested )

Code: 
Sub CheckPS_noibang()
Worksheets("result").Range("A20:Z15000").Clear
Application.ScreenUpdating = False
Dim i As Integer, lastrow As Integer, lastrownoibang As Integer
   lastrownoibang = Sheets("noibang").Range("B" & Rows.Count).End(xlUp).Row + 1
   ' load the whole sheet inot a variant array
   With Sheets("noibang")
   
   inarr = Range(.Cells(1, 1), .Cells(lastrownoibang, 3))
   lastrow = Sheets("Result").Cells(Rows.Count, 2).End(xlUp).Row
    
    For i = 2 To lastrownoibang
            If (Left(inarr(i, 3), 1) = 5 Or Left(inarr(i, 3), 1) = 6 Or Left(inarr(i, 3), 2) = 47 Or Left(inarr(i, 3), 3) = 486 Or inarr(i, 3) = 20 Or inarr(i, 3) = 21 Or inarr(i, 3) = 22 Or inarr(i, 3) = 23 Or inarr(i, 3) = 24 Or inarr(i, 3) = 25 Or inarr(i, 3) = 26 Or inarr(i, 3) = 27 Or inarr(i, 3) = 28 Or inarr(i, 3) = 29 Or inarr(i, 3) = 30 Or inarr(i, 3) = 48) And (inarr(i, 4).Value - inarr(i, 5).Value) + (inarr(i, 6).Value - inarr(i, 7).Value) <> (inarr(i, 8).Value - inarr(i, 9).Value) Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Rows(lastrow + 1))
                     ' increment counter to avoid accessing workhseet again and again
                     lastrow = lastrow + 1
            ElseIf (Left(inarr(i, 3), 1) = 1 Or Left(inarr(i, 3), 1) = 2 Or Left(inarr(i, 3), 1) = 3 Or Left(inarr(i, 3), 1) = 8) And (inarr(i, 3) <> 12 And inarr(i, 3) <> 13 And inarr(i, 3) <> 14 And inarr(i, 3) <> 15 And inarr(i, 3) <> 16 And inarr(i, 3) <> 20 And inarr(i, 3) <> 21 And inarr(i, 3) <> 22 And inarr(i, 3) <> 23 And inarr(i, 3) <> 24 And inarr(i, 3) <> 25 And inarr(i, 3) <> 26 And inarr(i, 3) <> 27 And inarr(i, 3) <> 28 And inarr(i, 3) <> 29 And inarr(i, 3) <> 30 And Left(inarr(i, 3), 3) <> 149 And Left(inarr(i, 3), 3) <> 159 And Left(inarr(i, 3), 3) <> 169 And Left(inarr(i, 3), 3) <> 209 And Left(inarr(i, 3), 3) <> 219 And Left(inarr(i, 3), 3) <> 229 And Left(inarr(i, 3), 3) <> 239 And Left(inarr(i, 3), 3) <> 249 And Left(inarr(i, 3), 3) <> 259 And Left(inarr(i, 3), 3) <> 269 And Left(inarr(i, 3), 3) <> 279 And Left(inarr(i, 3), 3) <> 289 And Left(inarr(i, 3), 3) <> 299 And Left(inarr(i, 3), 3) <> 305) Then
                If (inarr(i, 4).Value + inarr(i, 6).Value - inarr(i, 7).Value) <> inarr(i, 8).Value Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Range("A" & lastrow + 1))
                     lastrow = lastrow + 1
                End If
            ElseIf (Left(inarr(i, 3), 1) = 4 Or Left(inarr(i, 3), 1) = 7 Or Left(inarr(i, 3), 3) = 209 Or Left(inarr(i, 3), 3) = 219 Or Left(inarr(i, 3), 3) = 229 Or Left(inarr(i, 3), 3) = 239 Or Left(inarr(i, 3), 3) = 249 Or Left(inarr(i, 3), 3) = 259 Or Left(inarr(i, 3), 3) = 269 Or Left(inarr(i, 3), 3) = 279 Or Left(inarr(i, 3), 3) = 289 Or Left(inarr(i, 3), 3) = 299 Or Left(inarr(i, 3), 3) = 305) And ((Left(inarr(i, 3), 2) <> 47) And (Left(inarr(i, 3), 3) <> 486) And (inarr(i, 3) <> 48) And (inarr(i, 5).Value + inarr(i, 7).Value - inarr(i, 6).Value) <> inarr(i, 9).Value) Then
                     .Rows(i).Font.Color = vbRed
                     .Rows(i).Copy (Sheets("Result").Rows(lastrow + 1))
                     lastrow = lastrow + 1
            End If
       End With
    Next i
Application.ScreenUpdating = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
VBA - floating photo
Replies
3
Views
526
RoryA
RoryA
Emka
  • Question Question
Web Scrap on Chrome via VBA
Replies
0
Views
155
Emka
Emka
WERNER SLABBERT
  • Question Question
Run-time error 70 after code changed
Replies
3
Views
118
RoryA
RoryA
E
  • Solved
VBA code to change color of text based on location of active cell?
2
Replies
13
Views
795
Akuini
Akuini
K
  • Question Question
VBA code to reference worksheet second from the end
Replies
1
Views
231
John_w
J

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

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