Speed up macro

**Jasrenkai** · 07-19-2010, 07:01 PM

Looking for help speeding up a macro

Hi, sorry to ask for help here was just wondering if anybody had some time to help me with an issue I have.

I use Excel 2007 and Windows 7, and I have this series of macros. The main macro calls different other macros through its general run. It works and everything just fine but I really need to make it faster, as the size of the data that it runs over can be VERY large and can take some time to run. I have read about a number of things that haven’t really helped a lot, like disabling events, screenupating, page breaks, status bar etc. Some of them didn’t help at all, some of them did in certain parts so I /think/ I have those covered.

The main problem I have with it is all the information varies….the size, columns/rows, can be very large very small, numerous. Anyways if anyone sees any ways to speed it up significantly please let me know! And thanks for any possible help for a first time poster!

Sub ListNums()

    Dim Fnd As Range
    Dim c As Range
    Dim Rng As Range
    Dim txtFnd As String
    Dim txt As String
    Dim i As Long
    Dim FirstAddress As String
    Dim cel As Range
    Dim DataBlock As Range
    Dim Col As Long
    Dim Result As Long
    Dim startpos As Range
    Dim oset As Long
    Dim RWS(), r As Long
    Dim x As Long
    Dim oldstatusbar
    Dim ColRng As Range
    Dim MyCol As Long

    MyCol = 3
    Application.Calculation = xlManual
    On Error Resume Next
    Set c = Application.InputBox("Select first cell of first matrix", "Start Position", Type:=8)
    If c.Address = "" Then Exit Sub
    On Error GoTo 0

    Cells(1, 1) = Format(Now(), "hh:mm:ss")


    With Range(c.End(xlToRight).Offset(, 1), Range("XFD20000"))
        .ClearContents                      '<=== Clears previous data
        .Interior.ColorIndex = xlNone       'clears old colouring
    End With

    Application.ScreenUpdating = False

    Call Matrices(c)
    Call Spacing
    Call Matrices(c)

    Res = 0

    For Each m In Matrix
        'progress counter
        MyCol = 3
        x = x + 1
        Application.DisplayStatusBar = True
        Application.StatusBar = "Processing matrix " & x & " of " & UBound(Matrix) + 1 & " : please be patient..."

        'Set column positions
        Cols = Range(m).CurrentRegion.Columns.Count
        colA = FC + Cols + 5
        colB = FC + 2 * Cols + 10
        colC = FC + 2 * Cols + 17
        colD = 0


        'set cell to start search
        Res = Range(m).Row
        FirstAddress = ""
        Result = 0

        'get matrix area
        Set DataBlock = Range(m).CurrentRegion
        Set Fnd = DataBlock(1)

        'Look for ?
        Set c = DataBlock.Find(What:="~?", after:=Fnd, LookIn:=xlValues, lookat:= _
                               xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)

        Do
            txtFnd = ""
            If FirstAddress = "" Then FirstAddress = c.Address
            Set Fnd = c
            'Get width of cells to compare
            Col = c.Column - FC
            If Col = 0 Then Exit Do
            Set Rng = Cells(c.Row, FC).Resize(, Col)
            Rng.Select
            'Build check string
            For Each cel In Rng
                txtFnd = txtFnd & cel
            Next
            'Check each row for result; if found, store row number in array RWS
            ReDim RWS(10000)
            r = 0

            For i = DataBlock(1).Row To c.Row
                txt = ""
                For Each cel In Cells(i, FC).Resize(, Col)
                    txt = txt & cel
                Next
                'Collect result rows
                If txt = txtFnd Then
                    RWS(r) = i
                    r = r + 1
                End If
            Next i

            'if more than 2 results, analyse data
            If r > 2 Then
                MyCol = MyCol + 1
                ReDim Preserve RWS(r - 1)
                'Offset long column result

                'Copy rows to colA
                For i = 0 To r - 1
                    Cells(Res, colA).Resize(, Cols).Value = Cells(RWS(i), FC).Resize(, Cols).Value
                    Res = Res + 1
                Next
                Call NextStep(Cells(Res - 1, colA).CurrentRegion)
                Res = Res + 7
            End If
            Set c = DataBlock.Find(What:="~?", after:=Fnd, LookIn:=xlValues, lookat:= _
                                   xlWhole, searchorder:=xlByRows, searchdirection:=xlNext)

        Loop Until c.Address = FirstAddress
    Next m

    Application.StatusBar = "Clearing blank rows : please wait"
    Call RemRows

    Range(Matrix(0)).Select
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.StatusBar = "Ready"
    Cells(2, 1) = Format(Now(), "hh:mm:ss")
    Application.Calculation = xlAutomatic

End Sub

Sub NextStep(Data As Range)
    Dim c As Range
    Dim Rng As Range
    Dim Tgt As Range
    Dim s_d As Range
    Dim i As Long
    Dim Cnt As Long
    Dim x As String
    Dim Rw As Long

    'Data.Select
    Rw = Data(1).Row
    Set c = Data.Find(What:="~?", after:=Data(1), LookIn:=xlValues, lookat:= _
                      xlWhole, searchorder:=xlByColumns, searchdirection:=xlNext)
    Set Rng = Intersect(Columns(c.Column), Data)
    Set Tgt = Cells(Rw, colC)

    Cnt = Rng.Cells.Count

    Rng.Copy Cells(Rw, colB)
    Rng.Select
    Rng.Copy
    Tgt.Select
    Tgt.PasteSpecial Transpose:=True
    
    Call Add_S_D(Tgt, Cnt)

    Call FilterResults(Tgt, Cnt)
    
    'Analyse data if more than MinRows
    If Cnt > MinRows + 1 Then CopyResults2 Rw, Cnt, Res

End Sub

Sub FilterResults(Tgt As Range, Cnt As Long)
    Dim i As Long, j As Long, LastVal As String
    Dim c As Range
    LastVal = Tgt.Offset(Cnt - 2, Cnt - 2)
    j = 0
    For i = 1 To Cnt - 2
        Set c = Tgt.Offset(i, 0).Resize(, Cnt - 1).Find(LastVal)
        If Not c Is Nothing Then
            j = j + 1
            Range(c, c.End(xlToRight)).Copy
            
            Tgt.Offset(j, Cnt + 4).PasteSpecial xlValues
            
        End If
    Next
End Sub

Sub CopyResults2(Rw As Long, Cnt As Long, Res As Long)
    Dim i As Long, j As Long, LastVal As String
    Dim Tgt As Range
    Dim QRow As Range
    Dim Dcol As Range
    Dim s_d As Range, x As String
            
    
        If colD > 0 Then colA = colD

        Range(Cells(Rw, colA), Cells(Rw, colB)).Resize(Cnt).Copy
        Res = Res + 6
        Cells(Res, colA).PasteSpecial xlValues

        Set Dcol = Cells(Res, colB).Resize(Cnt)
        'Dcol.Select
        For i = 1 To Dcol.Count Step 2
            Dcol(i).Resize(2).Copy Cells(Res, colC).Offset(, j)
            j = j + 1
        Next

        Set Dcol = Cells(Res, colC).CurrentRegion
        'Dcol.Select
        Set Tgt = Dcol.Find("~?")
        Set QRow = Intersect(Tgt.EntireRow, Dcol)
        Set Tgt = Dcol(1).Offset(4)
        Cnt = QRow.Count
        QRow.Copy Tgt

        Call Add_S_D(Tgt, Cnt)
        
        Call FilterResults(Tgt, Cnt)

    Res = Cells(Rows.Count, colA).End(xlUp).Row + 6
End Sub

'Add s & d checking formulae and counts
Sub Add_S_D(Tgt As Range, Cnt As Long)
Dim i As Long
Dim x As String
Dim s_d As Range

'Add s & d
    For i = 1 To Cnt - 2
        Tgt.Offset(i, i).Resize(, Cnt - i).FormulaR1C1 = _
        "=IF(R[-1]C=""?"",""?"",IF(R[-1]C[-1]=R[-1]C,""s"",""d""))"
        Application.Goto Tgt.Offset(i, i)
    Next
    If Cnt > 2 Then
        Set s_d = Tgt.Offset(1, 1).Resize(Cnt - 2, Cnt - 2)
        x = s_d.Address(ReferenceStyle:=xlR1C1)
    End If

    If Cnt < 3 Then Cnt = 3
    Tgt.Offset(Cnt - 3, -5).Resize(, 2) = Array("s", "?")
    Tgt.Offset(Cnt - 2, -5).Resize(, 2) = Array("d", "?")
    If Not x = "" Then
        Tgt.Offset(Cnt - 3, -3).FormulaR1C1 = "=COUNTIF(" & x & "," & """s""" & ")"
        Tgt.Offset(Cnt - 2, -3).FormulaR1C1 = "=COUNTIF(" & x & "," & """d""" & ")"
    End If
End Sub


'Get list of marices start locations
Sub Matrices(r As Range)
    
    Dim i%

    FR = r.Row
    FC = r.Column
    ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
    Cells(1, FC - 1).Resize(15000).Interior.ColorIndex = 3
    
    ReDim Matrix(200)
    
    'Create list of matices
    Matrix(0) = Cells(FR, FC).Address
    Do
        i = i + 1
        Matrix(i) = Range(Matrix(i - 1)).End(xlDown).End(xlDown).Address
    Loop Until Range(Matrix(i)).Row = Rows.Count
    ReDim Preserve Matrix(i - 1)
End Sub
    
'Space out matrices to avoid overlapping data
Private Sub Spacing()
     Dim i%, j%, Rw%
     Dim r As Range
     For j = UBound(Matrix) To 1 Step -1
        Set r = Range(Matrix(j))
        Rw = r.Row - r.End(xlUp).Row
       
        
        If Rw < Spacerows Then
            r.Resize(Spacerows - Rw).EntireRow.Insert
        ElseIf Rw > Spacerows Then
            r.Offset(-Rw).Resize(Rw - Spacerows).EntireRow.Delete
        End If
        
    Next
End Sub

'Tidy up at end removing excess rows between matrices & Data
Private Sub RemRows()
    Dim i%, j%, k%
    Dim r As Range

    For j = UBound(Matrix) To 1 Step -1
        Set r = Range(Matrix(j)).Offset(-6)
        k = 0
        Do
            k = k + 1
        Loop Until Application.CountA(r.Offset(-k).EntireRow) > 0
        Cells(r.Row + 1, 1).Resize(2, 500).Interior.ColorIndex = 1
        Range(r, r.Offset(-k + 10)).EntireRow.Delete
    Next
End Sub

**JBeaucaire** · 07-19-2010, 07:09 PM

Tip #1 - remove the STATUS BAR coding, updating and displaying status reports greatly reduces speed.

**Jasrenkai** · 07-19-2010, 09:24 PM

Thanks JBeaucaire, I really appreciate your response.

I had read the same thing, and tried it out and it didnt /seem/ to make any difference. Since you mentioned it I went ahead and tested it, first I ran it twice with two matrices and got the times of 34 and 35 seconds.

Then I took out the :

Dim oldstatusbar
Application.DisplayStatusBar = True
        Application.StatusBar = "Processing matrix " & x & " of " & UBound(Matrix) + 1 & " : please be patient..."
   
    Application.StatusBar = "Ready"

And added at the begining and end:

Application.DisplayStatusBar = False
Application.DisplayStutasBar = True

I got 47 seconds and 47 seconds on the same two matrices.

Then reverted back to the original and ran it again and got 36 and 35 seconds.

So I am not sure exactly how it will respond to 100 matrices versus 2, maybe it would make it faster with a bunch more to process but with just a few it seemed to make it take longer which is weird. Let me try it with no Status Bar code at all.

Edit: With no status bar coding at all (not eveing making it false and true, just nothing) I got 45 and 47 seconds. Then I thought to myself maybe storing x and mycol in the first part but not really doing anything with it made it slow down. So I took out x = x +1 and all the MyCol lines and got 46 and 47 seconds. Went ahead and reverted it back to original code and got 36 and 35 seconds. =(