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

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
Main sheet(All Programs) has 200 Names and 24 months (values to be calculated based on other sheets )
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

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!

Answer 2

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