Macro very slow and becomes unresponsive or am I impatient

G

ghrek

Active Member
Joined
Jul 29, 2005
Messages
426
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
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 11000 rows it is much quicker to load the 11000 lines into a variant array ( one worksheet access), and then usethe variant array to load the collections. I have modified your code to change it to using a couplke of variant arrays so it should be at least 1000 times faster. and I mean one thousand times faster !!


I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
the code is untest so probably needs some debugging:
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
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 = i + tablestart ' 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
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 = i + tablestart
        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
Range(Tableadd).Offset(DU1.Range, 4) = DU1.Report


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

'report 2nd group
For Each DU1 In colB
Range(Table2add).Offset(DU1.Range, 4) = DU1.Report
Next
End Sub
 
Upvote 0
Many thanks for that.

at this line
VBA Code: 
 [CODE=vba] Set DU1.Range = i + tablestart ' this is just storing the row numberin the table

I get runtime error 424 object required??


Any ideas?
 
Upvote 0
Youi probably need to change the definition of the DUI object so that you aren't storing a range but an index ( long) which is all you need, The range object is a very large object and takes masses of resources to store, so you should avoid using them if you can. You certainly don't need it for this because you can use the range row number and columnber number instaed to writethe report out.
 
Upvote 0
At the top of your code you define du1 as c_dataunit, you need to find and modify the code in that module
 
Upvote 0
In other words, you declared du1 = c_dataunit. What exactly is a c_dataunit. It does not exist. Excel will not compile this code because there is no such object called c_dataunit that is defined by Excel.
 
Upvote 0
I dont know what a C-Dataunit is .Is that something that Im missing from the sheet as dont think it should be there.
 
Upvote 0
Quoted from your original post...

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
Click to expand...
 
Upvote 0
Apologies for sounding thick but I would say thats the data sources im using TAB & WFJ?
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Solved
VBA listing folders, sub-folders & file names - modification required
Replies
5
Views
348
NdNoviceHlp
NdNoviceHlp
R
  • Question
Filter & Delete Deleting Header Row Suddenly
Replies
0
Views
213
reberryjr
R
R
  • Solved
extract date but exclude Time
Replies
2
Views
272
rikvny02
R
C
  • Solved
VBA Folder Structure -- Loop Once
Replies
2
Views
431
cwhaley1
C
O
  • Question
VBA Modification: criteria on two subfolder to open
Replies
0
Views
195
OrangeYellow
O

Forum statistics

Threads
1,214,627
Messages
6,120,610
Members
448,973
Latest member
ChristineC

Share this page

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
Back
Top