VB Script for Excel taking very long time to calculate the values

Question

I am writing a vb script on excel below is my problem.

I have more than 20 sheets in excel and one main sheet (All Programs with 200 names). Each sheet has column with Names and 24months(Jan18 to Dec18, Jan19 to Dec20). Each sheet names is subset of main sheet

1. Main sheet(All Programs) has 200 Names and 24 months (values to be calculated based on other sheets )
2. Other sheet has names and values for each month respective to main sheet

I need to take each name in main sheet and search the name all other sheet, if present sum all same column values and insert in main sheet .

For 1 name i need to do calculation on 34 cells (For 200 names * 34 cells = 6800 cells) . Its taking almost 20minutes with my above code. Is there any other way i can do it or any modification which improves the performance?

Below is my code and example

Thanks in advance.

Example :

Main Sheet has name "employee1"

Sheet1

Sheet2

Value on the main sheet should be calculated respect to months

Dim sheetCount As Integer
Dim datatoFind
Private Sub CommandButton1_Click()
    Dim mainSheet As String: mainSheet = "All Programs"
    Dim nameColumnStart As String: nameColumnStart = "A"

    Dim namesStart As Integer: namesStart = 1
    Dim namesEnd As Integer: namesEnd = 200

    Dim startColumn As Integer: startColumn = 10 'J Column'
    Dim EndColumn As Integer: EndColumn = 33 'AG Column'

    namesStart = InputBox("Please enter start value")
    namesEnd = InputBox("Please enter end value")


    Dim temp_str As String
    Dim total As Single
    On Error Resume Next
    Sheets(mainSheet).Activate
    lastRow_main = ActiveCell.SpecialCells(xlLastCell).Row
    lastCol_main = 34
    For vRow = namesStart To namesEnd
        temp_str = Sheets(mainSheet).Cells(vRow, "A").Text
        datatoFind = StrConv(temp_str, vbLowerCase)
            For vCol = startColumn To EndColumn
                total = Find_Data(vCol)
                Worksheets(mainSheet).Cells(vRow, vCol).Value = total
            Next vCol
    Next vRow
    Sheets(mainSheet).Activate
    'MsgBox ("Calculated all values")'
End Sub


Private Function Find_Data(ByVal ColumnName As Integer) As Single
    Dim counter As Integer
    Dim currentSheet As Integer
    Dim sheetCount As Integer
    Dim str As String
    Dim lastRow As Long
    Dim lastCol As Long
    Dim val As Single

    Find_Data = 0

    currentSheet = ActiveSheet.Index

    If datatoFind = "" Then Exit Function

    sheetCount = ActiveWorkbook.Sheets.Count

    For counter = 2 To sheetCount

        Sheets(counter).Activate

        lastRow = ActiveCell.SpecialCells(xlLastCell).Row
        lastCol = ActiveCell.SpecialCells(xlLastCell).Column

        For vRow = 1 To lastRow
                str = Sheets(counter).Cells(vRow, "A").Text
                If InStr(1, StrConv(str, vbLowerCase), datatoFind) Then
                        val = Sheets(counter).Cells(vRow, ColumnName).Value
                        Find_Data = Find_Data + val
                End If
        Next vRow

    Next counter

End Function

Answer 1

Please try replace this code:

For vRow = namesStart To namesEnd
    temp_str = Sheets(mainSheet).Cells(vRow, "A").Text
    datatoFind = StrConv(temp_str, vbLowerCase)
        For vCol = startColumn To EndColumn
            total = Find_Data(vCol)
            Worksheets(mainSheet).Cells(vRow, vCol).Value = total
        Next vCol
Next vRow

With:

With Sheets(mainSheet)

    For vRow = namesStart To namesEnd
        temp_str = .Cells(vRow, "A").Text
        datatoFind = StrConv(temp_str, vbLowerCase)
        For vCol = startColumn To EndColumn
            total = Find_Data(vCol)
            .Cells(vRow, vCol).Value = total
        Next vCol
    Next vRow

End With

And this code:

    For vRow = 1 To lastRow
            str = Sheets(counter).Cells(vRow, "A").Text
            If InStr(1, StrConv(str, vbLowerCase), datatoFind) Then
                    val = Sheets(counter).Cells(vRow, ColumnName).Value
                    Find_Data = Find_Data + val
            End If
    Next vRow

replace with:

    With Sheets(counter)

        For vRow = 1 To lastRow
            str = .Cells(vRow, "A").Text
            If InStr(1, StrConv(str, vbLowerCase), datatoFind) Then
                val = .Cells(vRow, ColumnName).Value
                Find_Data = Find_Data + val
            End If
        Next vRow

    End With

Answer 2

Why not collect the data on one sheet instead of different sheets?
Instead of sheets use a filter in column A!

And then use a pivot table to sum up everything!
The calculation is done in seconds!