Macro is running very slowly: how to speed up this macro?

Question

Friends,

I have a worksheet and I am using an "Auto Present" macro on it. But that macro is working very slowly, Slowly means it is taking more than 5 seconds to process even though other macros are taking only fraction of a second. I don't know why this is so.

So, friends My actual requirement and code I generated are posting below. Kindly help me to sort out this issue.

Actual Requirement of Mine.

I have a spreadsheet for entering Employee's details. On that I am entering employee's daily attendance status. I AM USING DATA VALIDATION ON EACH EMPLOYEE STATUS CELLS. Means , I am selecting the status of employees from the Data validation List menu. It is almost 600 employees and entering each and every employee's status is a herculean task. So What I need is, I can enter on the Absent, Casual Leave, and etc...and the remaining unmarked staffs will be PRESENT. So that I need a command button for that purpose. So, when I clicked that button it should automatically apply "P" on the remaining cells on that particular date's column. More clearly, I have 31 columns for each day in a month and on each column's 7th ROW contains that particular day's date. So the macro has to search the empty CELL's between current date's particular column and fill it with "P" while I click the command button. The empty cells will be between 8th row to 500th row on each day's column. One more thing the macro has to check. The empty cell on each day has to fill ONLY IF that cells respective "B" cell having any value (Where the Employee Names entered). More clearly, I am entering Employees name in the "B" Column from 8 th to 500th row. So, After clicking the command button, macro has to find that particular date containing column and find the empty cells between that column's 8th ROW to 500th ROW and fill those empty CELLS with "P", ONLY IF there is any name in the B column.

MY VBA CODE FOR AUTO PRESENT:

Private Sub Button506_Click()

    Dim BeginCol As Long
    Dim endCol As Long
    Dim ChkRow As Long
    Dim rng As Range
    Dim c As Variant

    Application.ScreenUpdating = False
    BeginCol = 6
    endCol = 37
    ChkRow = 7
    For Colcnt = BeginCol To endCol
           If Sheets("Sheet1").Cells(ChkRow, Colcnt).Value = Date Then
            Set rng = Sheets("Sheet1").Cells(ChkRow, Colcnt).Rows("2:500")
            For Each c In rng
                If Sheets("Sheet1").Cells(c.Row, 2).Value = "" Then
                    c.Value = "P"
                End If
            Next c
        Else
            'Sheets("Sheet1").Cells(ChkRow, Colcnt).EntireColumn.Hidden = True
        End If
    Next Colcnt

    Application.ScreenUpdating = True

End Sub

Answer 1

A quick way using Evaluate

This single line
x2 = Application.Evaluate("=IF((F8:AK500=""||"")*(F7:AK7=today())*(B8:B500<>""""),""p"",F8:AK500)")
is almost enough on its own ........ but it converts blank cells to 0. So a few more lines are needed to back that out :)

Sub Quick()
y = Application.Evaluate("=IF(F8:AK500="""",""||"",F8:AK500)")
[f8:Ak500] = y
x2 = Application.Evaluate("=IF((F8:AK500=""||"")*(F7:AK7=today())*(B8:B500<>""""),""p"",F8:AK500)")
[f8:Ak500] = x2
Range("f8:Ak500").Replace "||", vbNullString
End Sub

before

after

Answer 2

I dumped your code into a new workbook's Sheet1's module with Option Explicit declared and tried to compile it.

First up Colcnt hasn't been declared so I took a guess that Dim Colcnt as Long would suffice. That solved the compile error.

Next I set up dates from 1/1/14 to 31/1/14 in F7:AJ17, added a CommandButton and assigned Sub Button506_Click() to it.

In column B8:B508 I set up a Data Validation dropdown list Absent, Casual, Leave and picked random cells to populate with items from the dropdown list. Hit the button and it ran instananeously!

This was without Application.ScreenUpdating = False or Application.EnableEvents = False so the code by itself is good.

Try Application.Calculation = xlManual at the top of your code and Application.Calculation = xlAutomatic just before End Sub

Other issues could be:

• Dependent cells/calculations firing every time your macro changes a cell in F8:AJ508 so on the Formula tab check if there are any Dependents that may re-calculate when cells in the range change.
• Any other open workbooks - close them and try running your code.

You've already said that invoking Application.EnableEvents = False had no effect so I assume you have no event based procedures in the workbook or Personal.xls*

Answer 3

Maybe it helps to use some of excel built-in functions like find... I haven't tried it:

Dim BeginCol As Long
Dim endCol As Long
Dim ChkRow As Long
Dim firstAddress
Dim rng As Range
Dim Colcnt As Integer
Dim c As Variant

Application.ScreenUpdating = False
BeginCol = 6
endCol = 37
ChkRow = 7

'loop columns
For Colcnt = BeginCol To endCol
    'check date
    If CDate(Sheets("Sheet1").Cells(ChkRow, Colcnt).Value) = Date Then
        Set rng = Sheets("Sheet1").Cells(ChkRow, Colcnt).Rows("2:500")
        'start search
        Set c = rng.Find("", LookIn:=xlValues, LookAt:=xlWhole)

        If Not c Is Nothing Then
            'save first address to break loop later
            firstAddress = c.Address
            'loop through empty cells
            Do
                'if cell B of same row contains value, write "P"
                If Sheets("Sheet1").Cells(c.row, 2).Value <> "" Then
                    c.Value = "P"
                End If
                'next cell
                Set c = rng.FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End If
    DoEvents
Next Colcnt

Application.ScreenUpdating = True