Keep Duplicates in string

[BradleyS]

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:

'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)

 

[JEC]

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

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

 

[BradleyS]

Well that is a lot shorter, and it works great! Thank you so much.

 

[JEC]

You're welcome!