Keep Duplicates in string

BradleyS

Active Member
Joined
Oct 28, 2006
Messages
333
Office Version
  1. 2010
Platform
  1. Windows
I have a variable that stores a list of comma separated number values derived from multiple variables and combined, as shown in the grpCohort list below
grpCohort =
"88,9230,20958,588,1323,17595,18194,19185,20175,20485,21893,22607,72,979,1060,1532,2038,2537,3157,3738,4537,5590,7202,9854,10308,11001,12734,13608,14758,15544,16076,16316,17622,18733,19822,19947,19948,21418,2263,3,206,1593,3398,4829,5507,6035,6706,7811,8183,9131,9683,10171,10173,12101,14576,16316,18092,18547,18578,18613,19153,19763,19984,20087,20230,20333,20418,20574,20663,20780,21127,21130,22385,23098,3,1612,18029,14,300,457,768,927,1000,1469,1768,1803,2164,2247,2692,2707,2715,2924,2953,3263,3825,3919,4572,5300,6636,6783,7582,9690,10836,12190,14502,14648,15272,15535,16188,17084,17137,18202,18545,18652,18796,18797,18807,18909,19263,19423,19754,19755,19929,20090,20125,20149,20157,20261,20283,20290,20293,20304,20574,20726,20732,20918,20982,21118,21143,21258,21264,21378,21431,21442,21450,21459,21463,21505,21659,21666,21762,21797,21845,21846,21958,22047,22165,22196,22275,22303,22339,22450,22487,22793,22826,22883,22967,23013,23022,23182,23190,23193,23221,23293,23295,23296,23301,23345,23346,23353,23366,23368,23408,
23416,23417,23418,23423,532,3106,3327,3399,3923,4695,4744,5016,5028,5570,6036,7811,8171,10454,13813,14265,15803,16343,16528,16766,18424,18539,18612,19152,20425,20662,22060,22771,23435,11511,12401,16189,17011"

In this list there are 4 duplicates: 3, 7811, 16316, 20574

I wonder if there is a quite bit of VBA code that would simple create a new variable that stores the duplicate values?

What I currently do is:
1. Put them all on a worksheet
2. Sort them
3. Run a loop to mark all those with a duplicate
4. Run another loop to Delete all the ones not marked as duplicates
5. Then Delete the remaining duplicates to leave the very latest one.
6. I then put these back into another variable

My rather long method of code, that I'd ideally like to shorten:
VBA Code:
'Add to sheet
    Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "Duplicates"
    Sheets("Duplicates").Select
    Range("A1").Value = "IDs"
    
    Dim t As Variant
        t = Split(grpCohort, ",")
    Range("A2").Resize(UBound(t) - LBound(t) + 1).Value = Application.Transpose(t)
    'Count
    lr = Range("A" & Rows.Count).End(xlUp).Row
        On Error Resume Next    'if only 1 row
    'Sort
    Range("A1:A" & lr).Select
    Selection.Sort key1:=Range("A1"), order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
    'Mark duplicate Values in Column A
    Dim myCell As Range
    Dim myRange As Range
    
    Set myRange = Range(Cells(2, 1), Cells(lr, 1))

    For Each myCell In myRange
        If WorksheetFunction.CountIf(myRange, myCell.Value) > 1 Then
            myCell.Offset(, 1).Value = 1
        Else
            myCell.Offset(, 1).Value = 0
        End If
    Next
    'Delete all non-duplicates
    With ActiveSheet
        For Lrow = lr To 2 Step -1
            With .Cells(Lrow, "B")
                If Not IsError(.Value) Then
                    If .Value = 0 Then .EntireRow.Delete
                End If
            End With
        Next Lrow
    End With
    're-count
    lr = Range("A" & Rows.Count).End(xlUp).Row
        On Error Resume Next    'if only 1 row
    'delete duplicates of the duplicate values found
    ActiveSheet.Range("A1:B" & lr).RemoveDuplicates Columns:=1, Header:=xlYes

    're-count
    lr = Range("A" & Rows.Count).End(xlUp).Row
        On Error Resume Next    'if only 1 row

    'create new cohort of duplicates
    Dim duplicateIDs As String
    For Each entry In ThisWorkbook.ActiveSheet.Range("A2:A" & lr)
        If Not IsEmpty(entry.Value) Then
            RangeOutput = RangeOutput & entry.Value & ","
        End If
    Next

    duplicateIDs = Left(RangeOutput, Len(RangeOutput) - 1)
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
When the string is in A1, you can use this one.
The 4 values are stored in variable "sp"

This way you don't have sheet interaction

VBA Code:
Sub jec()
 Dim sp, ky, i As Long
 sp = Split([a1], ",")
 
 With CreateObject("scripting.dictionary")
   For i = 0 To UBound(sp)
     .Item(sp(i)) = .Item(sp(i)) + 1
   Next
   For Each ky In .keys
     If .Item(ky) < 2 Then .Remove ky
   Next
   sp = Join(.keys, ", ")
 End With
End Sub
 
Upvote 0
Solution
Well that is a lot shorter, and it works great! Thank you so much.
 
Upvote 0

Forum statistics

Threads
1,213,531
Messages
6,114,167
Members
448,554
Latest member
Gleisner2

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