Speed up VBA with 138k rows and ~330 sheet creation

I have a VBA script that does the following and I am trying to see if I can have it perform faster than 44 seconds:

  1. start with ~138k rows of data on sheets(“Data”)
  2. concatenate each cell in the row into a temp string variable
    • temp string will look some like this if my row are columns A:D, “I am cellAI am cell BI am cell CI am cell D”
  3. sort the column holding all temp strings, so I can see all duplicates
  4. filter to first temp string value to get the count of each occurrence
  5. copy count into a sheets(“reporting”) and hyperlink the count number
  6. create a new sheet that is opened from the hyperlink
    • in the end, after all count of duplicate strings are accounted for, I am creating 345 sheets
  7. copy the filtered results into the newly created sheet
  8. hide the sheet
  9. repeat steps 4 through 8

My question is, based on the amount of work being done, is 38 – 44 seconds reasonable or can it be in any way faster (less than 30 seconds)

Below is the code:

Option Explicit   Sub runReportV2()      '----------------------------------------------------------------------------------------------------------     '-V1 code     ' - allow user to create grouping of fields     ' - create temp strings of each row     ' - compare all temp strings with each other     ' - get count of each duplicate string occurrence and paste count to 'Report Summary' sheet     '----------------------------------------------------------------------------------------------------------     '----------------------------------------------------------------------------------------------------------     '-V2 code     ' - adding hyperlinks to aggregation count on Report Summary sheet     ' - linking hyperlinks to a new sheet with filtered row data from data sheet     '----------------------------------------------------------------------------------------------------------      'These will help speed things up     Application.Calculation = xlCalculationManual     Application.ScreenUpdating = False     Application.EnableEvents = False     Application.DisplayStatusBar = False     ActiveSheet.DisplayPageBreaks = False      Dim x As Double ' used for the For Loop when creating temp strings     Dim y As Double ' 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 Double ' 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 "SIM_c_site_id"     headerColl.Add "iim_c_FcstName"     headerColl.Add "iim_c_description"  '*********************************************      '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  '------------------------------------------------------------------------------------------------ '------------------------------------------------------------------------------------------------ ' '***This section will need to be updated once the user wants to add more aggregations (columns)*** '   'Alias the aggregation columns and possible the other columns '     '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 & "1"), _     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