VBA Optimizing macro loop

Question

The scenario is that I have 40 sheets and there can be up to ~5k rows in each sheet so I'm dealing with a lot of data which is causing this macro to run extremely slow. For example the first sheet alone has around 15219162 computations which only has about 380 rows. Is there a way to trim down the amount of computations my macro has to run?

There is 39326 unqiue twitter names so far which means 39326 x 387 rows in the first page.

Sub CountInvestorsByTwitterName()
    With Application
        .Calculation = xlCalculationManual: .ScreenUpdating = False: .DisplayAlerts = False
    End With
    Dim row_total As Long
    Dim Unique_Values_Sheet As Worksheet
    Set Unique_Values_Sheet = Sheets(Sheets.Count)
    Unique_Values_Sheet.Columns("B:XFD").EntireColumn.Delete
    Dim Unique_Values_Sheet_row_total As Long
    Unique_Values_Sheet_row_total = Unique_Values_Sheet.Cells(Rows.Count, "A").End(xlUp).Row
    Dim Unqiue_Twitter_Names As Range
    Set Unqiue_Twitter_Names = Unique_Values_Sheet.Range("A2:A" & Unique_Values_Sheet_row_total).Cells
    For Each s In Sheets
        If s.Name <> "UNIQUE_DATA" Then
            row_total = s.Cells(Rows.Count, "B").End(xlUp).Row
            For Each r In s.Range("B2:B" & row_total).Cells
                    Twitter_Name = r.Value
                    For Each c In Unqiue_Twitter_Names
                        If c.Value = Twitter_Name Then
                            With c
                                .Offset(0, 1).Value = CDbl(.Offset(0, 1).Value) + 1
                                .End(xlToRight).Offset(0, 1).Value = s.Name
                            End With
                        End If
                    Next
            Next
        End If
        ' Loop through first sheet
'        Exit For
    Next
    With Application
        .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .DisplayAlerts = True
    End With
End Sub

user3598756 · Accepted Answer · 2016-04-06 10:58:20Z

try this

Option Explicit

Sub CountInvestorsByTwitterName2()
    Dim row_total As Long
    Dim Unqiue_Twitter_Names As Range
    Dim found As Range

    Dim sht As Worksheet
    Dim r As Range, shtRng As Range

    With Application
        .Calculation = xlCalculationManual: .ScreenUpdating = False: .DisplayAlerts = False
    End With

    With Sheets("UNIQUE_DATA")
        .Columns("B:XFD").EntireColumn.Delete
        Set Unqiue_Twitter_Names = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)
    End With

    For Each sht In Sheets
        With sht
            If .Name <> "UNIQUE_DATA" Then
                Set shtRng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).SpecialCells(xlCellTypeConstants, xlTextValues)
                For Each r In shtRng
                    Set found = Unqiue_Twitter_Names.Find(What:=r.Value, LookIn:=xlValues, LookAt:=xlWhole)
                    If Not found Is Nothing Then
                        With found
                            .Offset(0, 1).Value = CDbl(.Offset(0, 1).Value) + 1
                            .End(xlToRight).Offset(0, 1).Value = sht.Name
                        End With
                    End If
                Next
            End If
        End With
    Next

    With Application
        .Calculation = xlCalculationAutomatic: .ScreenUpdating = True: .DisplayAlerts = True
    End With
End Sub

if not sufficiently fast, you could try some "array" approach, storing relevant sheet cells values in a array and performing searching with them

also a Dictionary approach could be worth examinating

Tim Couwelier · Accepted Answer · 2016-04-06 11:41:58Z

What I would do:

1) Clear the entire 'UNIQUE_DATA' sheet.
2) Loop through all worksheets, and if the name of the sheet isn't 'UNIQUE DATA', copy all rows with content to 'UNIQUE_DATA' (copy-paste rows, after detecting beforehand which rows, and at which lines to insert them)
3) Sort all rows in 'UNIQUE DATA' on the column containing the twitter handles. Macro code is easy to figure out if you macro-record it once.
4) Loop through all rows in sheet 'UNIQUE_DATA', and compare value of Twitter handle with the Twitter handle for the row below. If they match, delete the next row (and lower the upper bound of your loop counter).

You should end up with all unique Twitter handles. I do have to agree the last step may take some time. But at least doing this is a complexity of O(n) rather then O(n²) you currently have with two nested loops. Especially for high values of n, the time difference should be significant.

Collectives™ on Stack Overflow

VBA Optimizing macro loop

2 Answers 2

Comments

Comments

Your Answer

Hot Network Questions

Collectives™ on Stack Overflow

2 Answers 2

Comments

Comments

Your Answer

Sign up or log in

Post as a guest

Related