VB Script for Excel очень долго вычисляет значения

Question

Я пишу VB скрипт на Excel ниже, это моя проблема.

У меня более 20 листов в Excel и один основной лист (все программы с 200 именами). На каждом листе есть столбец с именами и 24 месяцами (с 18 января по 18 декабря, с 19 января по 20 декабря). Названия каждого листа являются подмножеством основного листа

1. Основной лист (Все программы) имеет 200 имен и 24 месяца (значения рассчитываются на основе других листов)
2. Другие листы имеют названия и значения для каждого месяца, соответствующие основному листу

Мне нужно взять каждое имя на главном листе и выполнить поиск по имени на всех остальных листах, если они присутствуют, суммировать все те же значения столбца и вставить в основной лист.

Для 1 имени мне нужно сделать расчет по 34 ячейкам (Для 200 имен * 34 ячейки = 6800 ячеек). Это занимает почти 20 минут с моим кодом выше. Есть ли другой способ, которым я могу это сделать, или любая другая модификация, которая улучшает производительность?

Ниже мой код и пример

Заранее спасибо.

Пример:

Основной лист имеет имя "employee1"

Лист1

Лист2

Значение на основном листе должно быть рассчитано относительно месяцев

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

Пожалуйста, попробуйте заменить этот код:

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 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

И этот код:

    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

заменить на:

    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

Почему бы не собрать данные на одном листе, а не на разных листах?
Вместо листов используйте фильтр в столбце A!

А затем используйте сводную таблицу, чтобы подвести итоги!
Расчет производится за считанные секунды!