Optimization VBA code

ahmad123 · Jun 7th 2011

PHP

Hi folks,

I have a vba code that uses data from a huge spreadsheet "RAW" (more then 5000 rows and 50 columns) and generate data in another spreadsheet "Burndown (filter)"

This code is taking long long time to be executed, and i need to use it lot of times, so it is not teffecient at all to keep it like this.
Following is my code, and let the gurus play [Blocked Image: http://www.mrexcel.com/forum/images/smilies/icon_wink.gif]

[PT]Sub Month_1()

Sheets("RAW").Select
Dim rawlastline As Integer
Dim i As Integer
Dim x As Integer
Dim cell As Integer

rawlastline = 2
Do While Cells(rawlastline + 1, 1).Value <> ""

rawlastline = rawlastline + 1
Loop

For x = 2 To 13

cell = 0

i = 2
Do Until i = rawlastline
If Sheets("RAW").Rows(i).Hidden = False Then
If Month(Sheets("raw").Cells(i, 2)) = Month(Sheets("Burndown (filter)").Cells(1, x)) Then

cell = cell + 1

Sheets("Burndown (filter)").Select

Cells(7, x).Value = cell

End If
End If

i = i + 1
Loop

cell = 0

i = 2
Do Until i = rawlastline
If Sheets("RAW").Rows(i).Hidden = False Then
If Sheets("raw").Cells(i, 18) <> "#" Then

If Month(Sheets("raw").Cells(i, 18)) = Month(Sheets("Burndown (filter)").Cells(1, x)) Then

' DoEvents

cell = cell + 1

Sheets("Burndown (filter)").Select

Cells(6, x).Value = cell

End If
End If

End If

i = i + 1
Loop

Next
For x = 2 To 13

i = 2

Do Until i = rawlastline
If Sheets("RAW").Rows(i).Hidden = False Then
Sheets("raw").Select

x = x + 49
Sheets("raw").Select

If Not Cells(i, x).Value = "" Then

If Sheets("raw").Cells(i, x).Value <= 30 And Sheets("raw").Cells(i, x).Value <> 0 Then

'DoEvents

Sheets("Burndown (filter)").Select

x = x - 49

Cells(2, x).Value = Cells(2, x).Value + 1

x = x + 49

ElseIf Sheets("raw").Cells(i, x).Value > 30 And Sheets("raw").Cells(i, x).Value <= 60 Then
Sheets("Burndown (filter)").Select
x = x - 49

Cells(3, x).Value = Cells(3, x).Value + 1

x = x + 49

ElseIf Sheets("raw").Cells(i, x).Value > 60 And Sheets("raw").Cells(i, x).Value <= 90 Then
Sheets("Burndown (filter)").Select
x = x - 49
Cells(4, x).Value = Cells(4, x).Value + 1

x = x + 49
ElseIf Sheets("raw").Cells(i, x).Value > 90 Then
Sheets("Burndown (filter)").Select

x = x - 49
Cells(5, x).Value = Cells(5, x).Value + 1
End If

End If

i = i + 1
If x > 14 Then
x = x - 49
End If

Loop

Next
'Application.ScreenUpdating = True

End Sub

[/PT]THANK YOU IN ADVANCE !!

ahmad123 · Jun 7th 2011

Re: Optimization VBA code

EDIT: Please use code tags or your topic will be deleted. Thanks.

Here is the code :

Code

Sub Month_1()


Sheets("RAW").Select
Dim rawlastline As Integer
Dim i As Integer
Dim x As Integer
Dim cell As Integer


rawlastline = 2
Do While Cells(rawlastline + 1, 1).Value <> ""




rawlastline = rawlastline + 1
Loop


For x = 2 To 13


cell = 0


i = 2
Do Until i = rawlastline
If Sheets("RAW").Rows(i).Hidden = False Then
If Month(Sheets("raw").Cells(i, 2)) = Month(Sheets("Burndown (filter)").Cells(1, x)) Then




cell = cell + 1


Sheets("Burndown (filter)").Select


Cells(7, x).Value = cell






End If
End If


i = i + 1
Loop


Next


For x = 2 To 13


cell = 0


i = 2
Do Until i = rawlastline
If Sheets("RAW").Rows(i).Hidden = False Then
If Sheets("raw").Cells(i, 18) <> "#" Then


If Month(Sheets("raw").Cells(i, 18)) = Month(Sheets("Burndown (filter)").Cells(1, x)) Then


' DoEvents


cell = cell + 1


Sheets("Burndown (filter)").Select


Cells(6, x).Value = cell






End If
End If


End If


i = i + 1
Loop


Next
For x = 2 To 13






i = 2


Do Until i = rawlastline
If Sheets("RAW").Rows(i).Hidden = False Then
Sheets("raw").Select


x = x + 49
Sheets("raw").Select




If Not Cells(i, x).Value = "" Then




If Sheets("raw").Cells(i, x).Value <= 30 And Sheets("raw").Cells(i, x).Value <> 0 Then


'DoEvents






Sheets("Burndown (filter)").Select


x = x - 49


Cells(2, x).Value = Cells(2, x).Value + 1


x = x + 49


ElseIf Sheets("raw").Cells(i, x).Value > 30 And Sheets("raw").Cells(i, x).Value <= 60 Then
Sheets("Burndown (filter)").Select
x = x - 49


Cells(3, x).Value = Cells(3, x).Value + 1


x = x + 49


ElseIf Sheets("raw").Cells(i, x).Value > 60 And Sheets("raw").Cells(i, x).Value <= 90 Then
Sheets("Burndown (filter)").Select
x = x - 49
Cells(4, x).Value = Cells(4, x).Value + 1


x = x + 49
ElseIf Sheets("raw").Cells(i, x).Value > 90 Then
Sheets("Burndown (filter)").Select


x = x - 49
Cells(5, x).Value = Cells(5, x).Value + 1
End If


End If


End If


i = i + 1
If x > 14 Then
x = x - 49
End If


Loop




Next
'Application.ScreenUpdating = True


End Sub

Display More

rbrhodes · Jun 8th 2011

Re: Optimization VBA code

Hi test this on a COPY of your workbook

Code

Option Explicit
Sub test()


Dim i As Long
Dim x As Long
Dim cel As Long
Dim ws As Worksheet
Dim rawlastline As Long


    'Speed
    Application.ScreenUpdating = False


    'Set as Active
    Sheets("RAW").Activate


    'Create object
    Set ws = Sheets("burndown (filter)")


    'Get last row of data: Bottom up
    rawlastline = Range("A" & Rows.Count).End(xlUp).Row


    With ws
        'All columns
        For x = 2 To 13
            'Init
            cel = 0
            'All rows
            For i = 2 To rawlastline
                
                'Test one
                If Rows(i).Hidden = False Then
                    If Month(Cells(i, 2)) = Month(ws.Cells(1, x)) Then
                        cel = cel + 1
                        .Cells(7, x).Value = cel
                    End If
                End If
                cel = 0
                
                'Test two
                If Cells(i, 18) <> "#" Then
                    If Month(Cells(i, 18)) = Month(ws.Cells(1, x)) Then
                        cel = cel + 1
                        .Cells(6, x).Value = cel
                    End If
                End If
                
                'Test three
                x = x + 49
                'Do largest to smallest (elimination)
                If Not Cells(i, x) = "" Then
                    If Cells(i, x) > 90 Then
                        .Cells(5, x) = Cells(5, x) + 1
                        x = x - 49
                    ElseIf Cells(i, x) > 60 Then
                        .Cells(4, x - 49) = Cells(4, x - 49) + 1
                    ElseIf Cells(i, x) > 30 Then
                        .Cells(3, x - 49) = Cells(3, x - 40) + 1
                    ElseIf Cells(i, x) > 0 Then
                        .Cells(2, x - 49).Value = Cells(2, x - 49).Value + 1
                    End If
                End If
            Next
        Next
    End With
    
    'Cleanup
    Set ws = Nothing
    
    'Reset
    Application.ScreenUpdating = True


End Sub

Display More

Optimization VBA code

Participate now!

Share