Ytdyklly

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