Optimize macro performance

[perfect_zed]

Hi everyone,

Recently I started dabbling with VBA to automate some Excel work and got the following script to work. The only problem is that it gets slower when more records are in the source file;



lines
time (seconds)
lines/sec


1200
3,14
382


2400
10
240


4000
26,4
152



This makes me believe I built something that gets slower the bigger the file is. Could anyone give me some pointers as to how to make this perform better? Would be very much appreciated! This is the script:

=====


Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Dim sObjectID As String
Dim dStartMaand As Integer
Dim dEndMaand As Integer
Dim nRowNum As Integer
Dim cellRange As Range
Dim nRowSource As Long
Dim x As String
Dim found As Boolean
nRowSource = 2

Do While Not IsEmpty(Sheets(1).Cells(nRowSource, 1))
sObjectID = Sheets(1).Cells(nRowSource, 1)
dStartMaand = Sheets(1).Cells(nRowSource, 8)
dEndMaand = Sheets(1).Cells(nRowSource, 9)

Sheets("Blad2").Select

Range("A2").Select
found = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = sObjectID Then
found = True
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If found = True Then
nRowNum = ActiveCell.Row
End If

Set cellRange = Range(Cells(nRowNum, (dStartMaand + 2)), Cells(nRowNum, (dEndMaand + 2)))
cellRange.Value = 1
nRowSource = nRowSource + 1
Loop

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True


=====
What it does?

In Sheet 1 I have multiple lines per object with a duration in months. In Sheet 2 I have 1 line per object, and the ranges get updated there.

Kind regards

[Dave]

A few things... stop using Selection, stop using ActiveCell and please use code tags. U will also need to provide more specific detail about where your data is, how U want it manipulated, what the expected outcome is and where exactly U want to put the results. HTH. Dave

[perfect_zed]

Hi Dave,

Thanks for your reply. I saw that the mod already put in the code tags. This is what I'm trying to achieve:

Input



ObjectID
Document
Object_DOI
Object_Start
Object_End
Month_Start
Month_End
Object_DOE
Type
Supplier


12ABC1
34
23/12/2011
23/12/2011 0:00
23/07/2012 0:00
0
7
23/01/2013 0:10
1
101530


12ABC1
34
23/12/2011
23/12/2011 0:00
23/07/2012 0:00
0
7
22/12/2011 14:05
1
101530


12ABC1
34
23/12/2011
23/12/2012 0:00
23/01/2014 0:00
12
25
23/01/2013 0:12
1
101530


12ABC1
34
23/12/2011
23/12/2012 0:00
23/01/2014 0:00
12
25
23/01/2013 0:12
1
101530


12ABC1
34
23/12/2011
29/05/2014 0:00
29/06/2015 0:00
29
42
29/05/2014 22:25
1
132640


12ABC1
34
23/12/2011
05/06/2015 0:00
05/07/2016 0:00
41
54
05/06/2015 22:26
1
132640


12ABC1
34
23/12/2011
05/06/2016 0:00
05/07/2017 0:00
53
66
05/06/2016 0:31
1
132640


12ABC1
34
23/12/2011
05/06/2017 0:00
05/07/2018 0:00
65
78
05/06/2017 0:31
1
132640


12ABC1
34
23/12/2011
05/06/2018 0:00
05/07/2019 0:00
77
90
05/06/2018 0:31
1
132640


23BCD2
34
24/12/2011
24/12/2011 0:00
24/01/2013 0:00
0
13
24/12/2011 0:08
2
147020



Output (before script)



ObjectID
0
1
2
3
4
5
6
7
8
9
10
11
12
13


12ABC1
0
0
0
0
0
0
0
0
0
0
0
0
0
0


23BCD2
0
0
0
0
0
0
0
0
0
0
0
0
0
0



Output (after script)



ObjectID
0
1
2
3
4
5
6
7
8
9
10
11
12
13


12ABC1
1
1
1
1
1
1
1
1
0
0
0
0
1
1


23BCD2
1
1
1
1
1
1
1
1
1
1
1
1
1
1





The input rows contain from&to dates of eligibility. Amount of months since start of object is what I'm calculating with.
So in the output rows;

Column 0 is the first month of Object 12ABC1, Column 1 is the second month of Object 12ABC1. Column 2 is the third month of Object 12ABC1 and so forth. This goes on to month 120 (i'm looking at a 12 month period).

I want to change 0's to 1's whenever there was a row with valid dates in Input. So in our example, for 12ABC1, months 0-7 were eligible, so those get marked as 1's. Next row of input is from month 12-25, so from column 12 - 25 this gets marked as 1's.

I re-wrote the code so it's readable in English:



Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False

Dim sObjectID As String
Dim dMonth_Start As Integer
Dim dMonth_End As Integer
Dim nRowNum As Integer
Dim cellRange As Range
Dim nRowSource As Long
Dim x As String
Dim found As Boolean
nRowSource = 2

Do While Not IsEmpty(Sheets(1).Cells(nRowSource, 1))
sObjectID = Sheets(1).Cells(nRowSource, 1)
dStartMaand = Sheets(1).Cells(nRowSource, 6)
dEndMaand = Sheets(1).Cells(nRowSource, 7)

Sheets("Output").Select

Range("A2").Select
found = False
Do Until IsEmpty(ActiveCell)
If ActiveCell.Value = sObjectID Then
found = True
Exit Do
End If
ActiveCell.Offset(1, 0).Select
Loop
If found = True Then
nRowNum = ActiveCell.Row
End If

Set cellRange = Range(Cells(nRowNum, (dStartMaand + 2)), Cells(nRowNum, (dEndMaand + 2)))
cellRange.Value = 1
nRowSource = nRowSource + 1
Loop

Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

[大灰狼1976]

Hi perfect_zed!
Welcome to vbax forum.
Please refer to the attachment. The results are generated in sheet2.
But I use column"type" as a row reference, If the real data is not like this, you need to modify the code.



--Okami

[perfect_zed]

Hi perfect_zed!
Welcome to vbax forum.
Please refer to the attachment. The results are generated in sheet2.
But I use column"type" as a row reference, If the real data is not like this, you need to modify the code.



--Okami

Hi Okami!

Just tried this and doesn't work exactly how it should for my purposes unfortunately. The column 'Type' is not unique in the big file and only contains around 30 variables for 900K rows. You could assume that it's not used in the file :).

Kind regards

[大灰狼1976]

OK, I see. The PC at home has no EXCEL, so it can only be processed tomorrow.
Except for this question, is there any other problem?


--Okami

[Jan Karel Pieterse]

I would suggest you to post an Excel file with some relevant sample data. And with your current code.

[perfect_zed]

Thanks guys! Okami's code worked after a few alterations to my own dataset :).

Now I have a final question when working with the results. My current input:



ObjectID
Type
NA from Column
0
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16


1

4
1
1
1
1
1
1
1
0
0
0
0
0
0
0
0
0
0


2

6
1
1
1
1
1
1
1
0
0
0
0
0
0
0
0
0
0


3

5
1
1
1
1
1
1
0
0
0
0
0
0
0
0
0
0
0


4

8
1
1
1
1
1
1
1
1
0
0
0
0
0
0
0
0
0



What I want to do:

For each row I pre-defined how many columns are filled with accurate data in column 'NA from Column' (for example, for ObjectID 1, accurate data is Not Available after Column 4). So, the cells after column 4 in that row, need to be filled with "NA". This was easy to build for me.

However, if the cell value = 1, it actually is credible data. My current code is below:



Dim nMax_Known As Integer
Dim nRowNum As Integer
Dim cellRange As Range
Dim nRowSource As Long
nRowSource = 2

Do While Not IsEmpty(Sheets(1).Cells(nRowSource, 1))
nMax_Known = Sheets(1).Cells(nRowSource, 3)

Set cellRange = Range(Cells(nRowSource, (nMax_Known + 5)), Cells(nRowSource, 20))

cellRange.Value = "NA"
nRowSource = nRowSource + 1
Loop


I tested this and it works, but as explained it needs to set the cell Value to "NA" only if current cell value = 0.

Could you guys help me with this final step? :)

[大灰狼1976]

Not sure.
cellRange.Value = "NA" →　cellRange.Replace 0, "NA"

[snb]

Doe de helpers hier een lol en plaats een Excel voorbeeldbestand, zoals JKP al vroeg.
Je maakt het helpers onnodig moeilijk. Verander anders je alias.

[perfect_zed]

Okami, that worked, thanks!

snb, zal ik voortaan doen, dank voor de tip!