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

[pupsia]

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...

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

 

[Fluff]

These changes should hopefully speed things up a bit

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

 

[Peter_SSs]

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.

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

 

[pupsia]

Fluff, your a genius!!
Thank you so much!! That worked like a charm!!

I still have so much to learn...

 

[Fluff]

Glad to help & thanks for the feedback.
But have a look at Peter_SSs code, its going to be even quicker

 

[pupsia]

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

 

[pupsia]

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...

 

[Peter_SSs]

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
2	Hdr
3	AA;BB;;CC;DD
4	XXX
5	XXX;YYY
6	XXX;YYY;ZZZ
Report

 

[pupsia]

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..

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

 

[pupsia]

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..