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!