Как ускорить VBA с 138 тыс. Строк и ~ 330 листов создания

Question

У меня есть сценарий VBA, который выполняет следующее, и я пытаюсь выяснить, могу ли я выполнить его быстрее, чем за 44 секунды:

1. начать с ~ 138 тыс. Строк данных на листах («Данные»)
2. объединить каждую ячейку строки в переменную временной строки
   • будет выглядеть примерно так, если в моей строке есть столбцы A: D: «Я клетка. Я клетка. Я клетка. Я клетка. Я клетка D»
3. отсортировать столбец, содержащий все временные строки, чтобы я мог видеть все дубликаты
4. фильтр по первому временному значению строки, чтобы получить счетчик каждого вхождения
5. копировать счетчик в листы («отчетность») и гиперссылку номер счета
6. создать новый лист, который открывается по гиперссылке
   • в конце, после того, как учтено все количество повторяющихся строк, я создаю 345 листов
7. скопировать отфильтрованные результаты во вновь созданный лист
8. скрыть лист
9. повторите шаги с 4 по 8

Мой вопрос, исходя из объема выполняемой работы, составляет 38 - 44 секунды или может быть быстрее (менее 30 секунд)

Ниже приведен код:

    'These will help speed things up
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayStatusBar = False
    ActiveSheet.DisplayPageBreaks = False

    Dim x, y As Long ' used for the For Loop when creating temp strings
    Dim tempStr1 As String ' cell value used to concatenate to str1 variable
    Dim str1 As String ' temp string from each cell value for the given row
    Dim aggStr As String ' temp string value used in the while loop
    Dim dataAggCount As Double ' get the last row on the rDataSheet in the while loop
    Dim count As Double: count = 1 ' used to get count of each temp string occurrence
    Dim overallRowCount As Double: overallRowCount = 2 ' this tells me which row to start on my next aggregation
    Dim aggCol As Long ' last column used on the rDataSheet. helps me know where to provide aggregation results (count variable)
    Dim pctdone As Single ' gives the statusBarForm the percentage completion
    Dim reportCount As Double ' used to provide next available row on reportSheet
    Dim sheetarray As Variant ' used to hold the worksheet creation variable. this is done in the while loop
    Dim rDataLastRow As Long ' get last row value when copying filtered data on rDataSheet
    Dim hOverallRowCount As Double ' get the overall row count to know where to paste the data in the sheetarray variable worksheet
    Dim hDataAggCount As Double ' get count of rows on temp string column

    'Variables for worksheets
    Dim rDataSheet As Worksheet: Set rDataSheet = Sheets(1) '!1 Sheet
    Dim reportSheet As Worksheet: Set reportSheet = Sheets(2)
    reportSheet.Name = "Report Summary"

'********** THESE COLLECTION VALUES ARE USER UPDATED ***********

    'Create Collection to hold items that are going to be used in the grouping
    Dim headerColl As New Collection

    headerColl.Add "column_nameA"
    headerColl.Add "column_nameB"
    headerColl.Add "column_nameC"

'*********************************************

    'array to hold all of the column numbers used for each grouping column
    Dim headerArray As Variant
    ReDim headerArray(1 To headerColl.count)

    'variables used to get colum letter
    Dim rFind As Range
    Dim colNum As Long
    Dim z As Long

    'get count of fields (columns) with data
    Dim colCount As Long: colCount = rDataSheet.Cells(1, Columns.count).End(xlToLeft).Column

    For z = 1 To headerColl.count
        'find the needed header from header collection and get the column number
        With rDataSheet.Range(Cells(1, 1), Cells(1, colCount))
            Set rFind = .Find(What:=headerColl(z), LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False)
            If Not rFind Is Nothing Then
                'gives me the column number
                colNum = rFind.Column
                'add column number to headerArray
                If z <> headerColl.count + 1 Then
                    headerArray(z) = colNum
                End If
            End If
        End With
    Next z
    Set rFind = Nothing

    'insert header from data sheet to report sheet
    reportSheet.Rows(2).Value = rDataSheet.Rows(1).Value

    'insert column for aggregating
    reportSheet.Cells(2, colCount + 1).Value = "nCount"

    'these variables are used for column numbers of the created columns above
    aggCol = colCount + 1

    'column letter conversion for the aggregation column
    Dim aggReportColLetter As String: aggReportColLetter = Col_Letter(aggCol)

    'column letter conversion for the aggregation column
    Dim lastReportColLetter As String: lastReportColLetter = Col_Letter(aggCol - 1)

    'set the progress label and show the form
    statusBarForm.LabelProgress.Width = 0
    statusBarForm.Show

    'update user on progress of script: this is where the temp strings will be produced and sorted
    With statusBarForm
            .LabelCaption.Caption = "Preparing data aggregation..."
    End With
    DoEvents

    'get count of rows on data sheet
    Dim dataRowCount As Double: dataRowCount = rDataSheet.Cells(Rows.count, 1).End(xlUp).Row

    'create tempStr column
    rDataSheet.Cells(1, colCount + 1).Value = "tempStr"
    str1 = vbNullString

    'create temp strings
    For y = 2 To dataRowCount
        For x = 1 To UBound(headerArray)
            tempStr1 = Cells(y, headerArray(x))
            str1 = str1 & tempStr1
            tempStr1 = vbNullString
        Next x
        rDataSheet.Cells(y, aggCol) = str1
        str1 = vbNullString
    Next y

    'create filter for sorting temp string column
    rDataSheet.Range("A1").AutoFilter
    'sort temp string column
    Columns("A:" & aggReportColLetter).Sort key1:=Range(aggReportColLetter & "2"), _
    order1:=xlAscending, Header:=xlYes

'********** THIS IS WHERE THE MAGIC HAPPENS **********
    'SUMMARY:
    ' - filter temp string
    ' - get the count of occurrences of temp string individual
    ' - paste count to 'Report Summary' sheet
    ' - create worksheet and paste aggregated row data results onto each sheet
    ' - do while the the row the temp string is on, is not greater than the overall row count
    Do While overallRowCount < dataRowCount

        'update progress bar percentage
         pctdone = Round((overallRowCount / dataRowCount) * 100, 2)
         With statusBarForm
            .LabelCaption.Caption = "Report Summary is " & pctdone & "%" & " complete."
            .LabelProgress.Width = pctdone * 2.7
        End With
        DoEvents

        rDataSheet.Select
        'row item to copy over to the 'Report Summary' sheet
        aggStr = Cells(overallRowCount, aggCol).Value

        'filter '!1' sheet to aggStr variable
        Range("$A$1:$" & aggReportColLetter & "$" & aggCol).AutoFilter Field:=aggCol, Criteria1:=aggStr

        'aggregation count (only counting visible rows)
        count = Application.Subtotal(103, Columns(aggCol)) - 1

        'last used row on the current aggregation
        dataAggCount = rDataSheet.Cells(Rows.count, aggCol).End(xlUp).Row

        'get count of rows on report sheet
        reportCount = reportSheet.Cells(Rows.count, 1).End(xlUp).Row

        With reportSheet
        'add row from data sheet to report sheet
            .Rows(reportCount + 1).Value = rDataSheet.Rows(overallRowCount).Value
        'copy aggregated result to 'Report Summary' sheet
            .Cells(reportCount + 1, aggCol).Value = count
        End With

        'next row to use for copying to 'Report Summary' sheet and aggregating
        overallRowCount = dataAggCount + 1

        aggStr = vbNullString

        'create new worksheet that will open up when the hyperlinked number is clicked
        Set sheetarray = Worksheets.Add(After:=Sheets(Sheets.count))
        sheetarray.Name = "!" & CStr(sheetarray.Index - 1)

''      create hyperlink to sheets created
        reportSheet.Select
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(reportCount + 1, aggCol), Address:="", SubAddress:= _
            "'" & sheetarray.Name & "'!A1", TextToDisplay:=""

        rDataLastRow = rDataSheet.Cells(Rows.count, 1).End(xlUp).Row

        hDataAggCount = rDataSheet.Cells(Rows.count, aggCol - 1).End(xlUp).Row

        hOverallRowCount = hDataAggCount - count + 1

        'copy filtered data from rDataSheet and paste into the newly created sheet
        sheetarray.Select
        sheetarray.Range("A1:" & lastReportColLetter & 1).Value = rDataSheet.Range("A1:" & lastReportColLetter & 1).Value
        sheetarray.Range("A2:" & lastReportColLetter & count + 1).Value = rDataSheet.Range("A" & hOverallRowCount & ":" & lastReportColLetter & rDataLastRow).Value
        'format the sheet
        sheetarray.Range(Cells(1, 1), Cells(1, aggCol - 1)).EntireColumn.AutoFit
        'hide the sheet
        sheetarray.Visible = xlSheetHidden
        rDataSheet.AutoFilterMode = False
        'set the sheet to nothing, so the same variable can dynamically be used again for the next aggregation row
        Set sheetarray = Nothing
    Loop

'********** Clean up the report and close out the routine **********

    'delete the temp string column
    With rDataSheet
        .Columns(aggCol).Delete
    End With

    'auto fit columns on the Report Summary sheet
    With reportSheet
        .Range(Cells(1, 1), Cells(1, aggCol)).EntireColumn.AutoFit
    End With

    'close out of the status bar
    Unload statusBarForm

    MsgBox "Aggregation results are now availabe!", vbOKOnly, "Aggregation Completion"

    'restore order to the Excel world
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayStatusBar = True
    ActiveSheet.DisplayPageBreaks = True

End Sub

'function that converts a number into a column letter
Function Col_Letter(lngCol As Long) As String
    Dim vArr
    vArr = Split(Cells(1, lngCol).Address(True, False), "$")
    Col_Letter = vArr(0)
End Function