Code works, but really slow. How to make it faster?

pupsia

Board Regular
Joined
Dec 2, 2015
Messages
67
Hello all,

I was able to write a code that I need and works, but one part of the code works really slow when there is a lot of data.

I need to work with huge lists sometimes, and when I tested the code with about 500 lines, I had to wait quite a lot of time.

Could someone please help me make the code faster? The "Loop" part is the one that takes up a lot of time. But as I`m still quite new to macro, not sure how to change that...

Code:
Sub Get_Unique_Senders()


    Dim r As Range, i As Long, ar
    Dim c As Integer
    


Application.ScreenUpdating = False




ThisWorkbook.Worksheets("Report").Range("C2", ThisWorkbook.Worksheets("Report").Range("C2").End(xlDown)).Copy Destination:=ThisWorkbook.Worksheets("Temp").Range("A1")


Sheets("Temp").Select




Set wb = ThisWorkbook.Worksheets("Temp")


    With wb
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With




For c = 2 To LastRow
    With Range("A" & c)
        .Value = WorksheetFunction.Trim(.Value)
    End With
    
    With Range("A" & c)
        If Right(.Value, 1) = ";" Then .Value = Left(.Value, Len(.Value) - 1)
    End With


wb.Range("A2:A" & LastRow).Select


Selection.Replace What:="; ", Replacement:=";", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False


Next




    Set r = wb.Range("A" & LastRow)
    Do While r.Row > 1
        ar = Split(r.Value, ";")
        If UBound(ar) >= 0 Then r.Value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.Copy
            r.Offset(1).Insert
            r.Offset(1).Value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop




With wb
    .Range("A1", .Range("A1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlYes
End With


ThisWorkbook.Worksheets("Temp").Range("A1", ThisWorkbook.Worksheets("Temp").Range("A12").End(xlDown)).Copy Destination:=ThisWorkbook.Worksheets("Sheet7").Range("A1")


ThisWorkbook.Worksheets("Sheet7").Columns(1).AutoFit


Sheets("Sheet7").Select


Application.ScreenUpdating = True


End Sub
 

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.
These changes should hopefully speed things up a bit
Code:
For c = 2 To LastRow
    With Range("A" & c)
        .Value = WorksheetFunction.Trim(.Value)
        If Right(.Value, 1) = ";" Then .Value = Left(.Value, Len(.Value) - 1)
    End With

Next

wb.Range("A2:A" & LastRow).Replace What:="; ", Replacement:=";", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
    Set r = Range("A" & LastRow)
    Do While r.Row > 1
        ar = Split(r.Value, ";")
        If UBound(ar) > 0 Then
            r.Offset(1).Resize(UBound(ar)).Insert shift:=xlDown
            r.Resize(UBound(ar) + 1).Value = Application.Transpose(ar)
        End If
        Set r = r.Offset(-1)
    Loop
 
Last edited:
Upvote 0
Could someone please help me make the code faster?
You should find this a big improvement. I've bypassed the need for the 'Temp' sheet & put the results directly to Sheet7.
I hope I have interpreted correctly what you want.

Code:
Sub pupsia()
  Dim d As Object
  Dim a As Variant, bits As Variant, itm As Variant
  Dim i As Long, j As Long, k As Long
     
  Set d = CreateObject("Scripting.Dictionary")
  d.CompareMode = 1
  With Sheets("Report")
    a = .Range("C2", .Range("C2").End(xlDown)).Value
  End With
    For i = 2 To UBound(a)
    If Right(a(i, 1), 1) = ";" Then a(i, 1) = Left(a(i, 1), Len(a(i, 1)) - 1)
    bits = Split(Replace(a(i, 1), "; ", ";"), ";")
    For Each itm In bits
      d(itm) = 1
    Next itm
  Next i
  With Sheets("Sheet7").Columns("A")
    .ClearContents
    .Cells(1).Value = a(1, 1)
    .Cells(2).Resize(d.Count).Value = Application.Transpose(d.keys)
    .AutoFit
    .Parent.Activate
  End With
  MsgBox "Done"
End Sub
 
Upvote 0
Fluff, your a genius!!
Thank you so much!! That worked like a charm!!
:biggrin:

I still have so much to learn...
 
Last edited:
Upvote 0
Glad to help & thanks for the feedback.
But have a look at Peter_SSs code, its going to be even quicker
 
Upvote 0
Peter_SSs, tested the code you added.

As I`m not that knowledgeable, not sure why, but the result is different from what it should be.
After my macro, the unique list is 205 long. With yours 348.

Not sure why there is such a difference though.

Basically, what I`m trying to do is get a list of unique values in Sheet "Report" Column C, to Sheet "Sheet7" Column A.

In the C column, the values look something like this:

Line2: AAA; BBB; CCC;
Line3: CCC;
Line4: DDD;
Line5: BBB; VVV; DDD; CCC;
and so on.

I need values like this in A column:

Line2: AAA
Line3: BBB
Line4: CCC
Line5: DDD
Line6: VVV
and so on.

Something like this
 
Last edited:
Upvote 0
As there are so many values, trying to figure out, with macro has the correct unique list right now...

There could be I was doing something wrong, and mist some data... Hmm...
 
Upvote 0
Obviously I don't have your data but the sample data I tested on gave the same results for both codes EXCEPT if any data happens to have two consecutive semicolons in one of the rows, eg AA;BB;;CC;DD
If that happens, I think that your code may give incorrect results.
For example, clear column A on Sheet7 and Temp and put this data only in Report. Then run your code and look at the results. Duplicates have not been removed correctly.
Then run my code on the same data.


Book1
C
2Hdr
3AA;BB;;CC;DD
4XXX
5XXX;YYY
6XXX;YYY;ZZZ
Report
 
Last edited:
Upvote 0
Hello Peter_SSs

Today I tested both macro and compared the lists. Also, to be 100% sure I was getting the correct data, I actually looked through most of the initial data to see how much I would more or less get if I did it manually.
Your macro gave 346 results, and my only 204. It was easy to see that mine was missing quite a lot of data... So when my manual counting went over 210, I was already sure, that I made a mistake..

I looked through the cells that had the missing information, so see if those cells are in some way unique, to figure out my mistake. As I though, they didn't have anything different about them. Well, they shouldn't. No entries like ";;" or something similar. The information is an auto generated report, so the data is added something like this.
VALUE + "; " + NEXT
VALUE + "; " and so on. if there is no next value, then at the end of the cell, there will be an extra "; ".

I tried to look for my mistake, but I still do not get, where I went the wrong way :(

Thank you so much for helping me with this!! If you hadn't done that, I would have been working with incomplete data with my macro :(
I think the data my and your macro should be the same, before the unique value part. So I`m guessing my mistake was with the part that removes duplicates. Tested it out some more, and on small size lists, it works fine. But when a large list is corrected, then is misses quite a lot, hundreds more or less..

Any idea why that could be? Its more for learning purposes, as I enjoy working with macro, even though I`m not that good with it yet..

While I was doing the manual check, I noticed that there are some unwanted ' signs in the initial data, so I added this part to the macro, though its a long macro to do such a small task..

Code:
Set wb = ThisWorkbook.Worksheets("Sheet7")

    With wb
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With



wb.Range("B2:B" & LastRow).Replace What:=Chr(39), Replacement:="", LookAt:=xlPart, SearchOrder:=xlByColumns, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
 
Upvote 0
As for the initial data, it could be really different things, names, emails, team names and so on. A more accurate example would be like this:

TorontoOperations; Accounts Enable-Disable;
Singapore Operations;
Banking;
Banking;
CanadianOps; *OttawaOperations
MPP Accounts Enable-Disable; Banking;
Banking;
John Smith; Banking; Name.Surname@mail.com;
Banking;
Banking;
Banking; Bank Recs; *UK Operations
Banking;
operations@business.com;
Accounts Enable-Disable;

<tbody>
</tbody>


Come cell can have a lot of values divided by "; ". I even saw about 10-12 different values.
Lines as never know ether, depends on the workload.
And duplicates are there all the time..
 
Last edited:
Upvote 0

Forum statistics

Threads
1,213,526
Messages
6,114,122
Members
448,550
Latest member
CAT RG

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