I need help speeding up a macro

[Jasrenkai]

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!

One thing suggested to me on another forum was the statusbar lines and removing them. I did tests and it actually made the macro run slower not faster.

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

 

[Jasrenkai]

Bump

 

[AlphaFrog]

I don't follow exactly what you are trying to do, but one suggestion would be to utilize the .Areas Collection instead of using a loop to define what you are calling DataBlocks. This may eliminate the need to have to loop through a lot of rows.

The example below Autofilters to hide blank rows. Then sets the visible cells to a range variable. Each contigious set of cells will be an Area in the range variable that can be referenced. Here's a quick example.

Raw data:

Excel Workbook
	A	B	C	D
1	Test1	Test2	Test3	Test4
2	Jan	Feb	Mar	Apr
3	Feb	Mar	Apr	May
4
5	Apr	May	Jun	Jul
6	May	Jun	Jul	Aug
7	Jun	Jul	Aug	Sep
8
9	Aug	Sep	Oct	Nov
10	Sep	Oct	Nov	Dec
...

Sub Areas_Collection_Demo()

    Dim LastRow%, rng As Range, i%
    
    LastRow = Range("B" & Rows.Count).End(xlUp).Row
    
    
    Range("B1:B" & LastRow).AutoFilter Field:=1, Criteria1:="<>"    'Autofilter and exclude blank rows
    Set rng = Range("A2:D" & LastRow).SpecialCells(xlVisible)       'Set rng to visible cells
    ActiveSheet.AutoFilterMode = False                              'turn off autofilter
    
    For i = 1 To rng.Areas.Count
        MsgBox "Area " & i & " address is " & rng.Areas(i).Address
    Next i
    
    MsgBox "2nd area, 2nd row, 2nd column value is " & rng.Areas(2).Cells(2, 2).Value
    
End Sub