Macro very slow and becomes unresponsive or am I impatient

ghrek

Active Member
Joined
Jul 29, 2005
Messages
273
Hi
I have the following macro that runs and the wheel keeps spinning. After 5 mins it still doing the same and when I click on the screen again it comes up un responsive.

Am I not allowing enough time or is there anyway the macro can be changed to show what lines it checking as it goes along so I know its running. It is trying to check 11,000 rows.

VBA Code:
Sub Test()
Dim colA As Collection
Dim colB As Collection
Dim DU1  As c_DataUnit
Dim DU2 As c_DataUnit
Dim r As Range
Dim i As Long
Dim n As Long

'collect first group
Set colA = New Collection

For Each r In Range("Table1[ID]")
    If Not IsEmpty(r) Then
   
        Set DU1 = New c_DataUnit
        DU1.f1 = r
        DU1.DataType = r.Offset(0, -1)
        DU1.f2 = r.Offset(0, 1)
        DU1.f3 = r.Offset(0, 2)
        DU1.f4 = r.Offset(0, 3)
        Set DU1.Range = r
        colA.Add DU1
    End If
Next



'collect second group
Set colB = New Collection

For Each r In Range("Table2[ID]")
    If Not IsEmpty(r) Then
   
        Set DU2 = New c_DataUnit
        DU2.f1 = r
        DU2.DataType = r.Offset(0, -1)
        DU2.f2 = r.Offset(0, 1)
        DU2.f3 = r.Offset(0, 2)
        DU2.f4 = r.Offset(0, 3)
        Set DU2.Range = r
        colB.Add DU2
    End If
Next

'get instance number of each data unit
'ie compare group to itself
For i = colA.Count To 1 Step -1
    Set DU1 = colA(i)
    For n = i - 1 To 1 Step -1
        Set DU2 = colA(n)
        If DU1.IsMatch(DU2) Then
            DU1.Instance = DU1.Instance + 1
        End If
    Next n
Next i

'same for 2nd group
For i = colB.Count To 1 Step -1
    Set DU1 = colB(i)
    For n = i - 1 To 1 Step -1
        Set DU2 = colB(n)
        If DU1.IsMatch(DU2) Then
            DU1.Instance = DU1.Instance + 1
        End If
    Next n
Next i


'compare each data unit 1st grp to 2nd grp
For Each DU1 In colA
    For Each DU2 In colB
        If DU1.IsMatch(DU2) Then
            DU1.Matches = DU1.Matches + 1
        End If
    Next DU2
Next DU1

'compare each data unit 2nd grp to 1st grp
For Each DU1 In colB
    For Each DU2 In colA
        If DU1.IsMatch(DU2) Then
            DU1.Matches = DU1.Matches + 1
        End If
    Next DU2
Next DU1


'clear report section of tables
Range("Table1[Result]").ClearContents
Range("Table2[Result]").ClearContents

'report 1st group
For Each DU1 In colA
DU1.Range.Offset(0, 4) = DU1.Report
Next

'report 2nd group
For Each DU1 In colB
DU1.Range.Offset(0, 4) = DU1.Report
Next


End Sub
 

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,820
Office Version
  1. 2010
Platform
  1. Windows
try this version which does save the range in dui.range , this will make it run a bit slower than my original version but still a lot faster than the original, but it does save you needing to change the definition of your custom objects:
VBA Code:
Sub Test()
Dim colA As Collection
Dim colB As Collection
Dim DU1  As c_DataUnit
Dim DU2 As c_DataUnit
Dim r As Range
Dim i As Long
Dim n As Long

'collect first group
Set colA = New Collection
' find start address of ID column
tablestart = Range("Table1").Row
tablecol = Range("Table1").Column
ttable = Range("Table1") '
Tableadd = Range("Table1").Address

For i = 1 To UBound(ttable, 1)
    If Not IsEmpty(ttable(i, 2)) Then
   
        Set DU1 = New c_DataUnit
        DU1.f1 = ttable(i, 2)
        DU1.DataType = ttable(i, 1)
        DU1.f2 = ttable(i, 3)
        DU1.f3 = ttable(i, 4)
        DU1.f4 = ttable(i, 5)
        Set DU1.Range = Range(Cells(i + tablestart, tablecol + 1), Cells(i + tablestart, tablecol + 1)) ' this is just storing the row numberin the table
        colA.Add DU1
    End If
Next i



'collect second group
Set colB = New Collection
table2start = Range("Table2").Row
table2col = Range("Table2").Column
ttable2 = Range("Table2") '
Table2add = Range("Table2").Address
For i = 1 To UBound(ttable2, 1)
    If Not IsEmpty(ttable2(i, 2)) Then
   
        Set DU2 = New c_DataUnit
        DU2.f1 = ttable2(i, 2)
        DU2.DataType = ttable2(i, 1)
        DU2.f2 = ttable2(i, 3)
        DU2.f3 = ttable2(i, 4)
        DU2.f4 = ttable2(i, 5)
        Set DU2.Range = Range(Cells(i + table2start, table2col + 1), Cells(i + table2start, table2col + 1)) '
        colB.Add DU2
    End If
Next i

'get instance number of each data unit
'ie compare group to itself
For i = colA.Count To 1 Step -1
    Set DU1 = colA(i)
    For n = i - 1 To 1 Step -1
        Set DU2 = colA(n)
        If DU1.IsMatch(DU2) Then
            DU1.Instance = DU1.Instance + 1
        End If
    Next n
Next i

'same for 2nd group
For i = colB.Count To 1 Step -1
    Set DU1 = colB(i)
    For n = i - 1 To 1 Step -1
        Set DU2 = colB(n)
        If DU1.IsMatch(DU2) Then
            DU1.Instance = DU1.Instance + 1
        End If
    Next n
Next i


'compare each data unit 1st grp to 2nd grp
For Each DU1 In colA
    For Each DU2 In colB
        If DU1.IsMatch(DU2) Then
            DU1.Matches = DU1.Matches + 1
        End If
    Next DU2
Next DU1

'compare each data unit 2nd grp to 1st grp
For Each DU1 In colB
    For Each DU2 In colA
        If DU1.IsMatch(DU2) Then
            DU1.Matches = DU1.Matches + 1
        End If
    Next DU2
Next DU1


'clear report section of tables
Range("Table1[Result]").ClearContents
Range("Table2[Result]").ClearContents

'report 1st group
For Each DU1 In colA
DU1.Range.Offset(0, 4) = DU1.Report

'DU1.Range.Offset(0, 4) = DU1.Report
Next

'report 2nd group
For Each DU1 In colB
DU1.Range.Offset(0, 4) = DU1.Report
Next
End Sub
 

Excel Facts

How can you turn a range sideways?
Copy the range. Select a blank cell. Right-click, Paste Special, then choose Transpose.

offthelip

Well-known Member
Joined
Dec 23, 2017
Messages
1,820
Office Version
  1. 2010
Platform
  1. Windows
c_dataunit, it is is in the original code that you posted. I don't know what it is, when run it on my machine I just get an error message "User defined type not defined". Looking at the code that you posted it is obviously an object that stores a number of variables and produces an output called report. The definition of this object is in your system somewhere or if it isn't this code will never work. What are you expecting this code to so? It doesn't look complicated , what are you expecting in the report? It might be simpler to rewrite all the code if you can't find c_dataunit
 

Watch MrExcel Video

Forum statistics

Threads
1,130,219
Messages
5,640,954
Members
417,182
Latest member
mgcorreia

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top