Sort, concatenate and count column data

I have a column of data that could have several hundred numerical entries in it with duplicates up to the number 288.
The column to the left is labeled top to bottom 1 through 288.
I'd like to middle column (where the large list resides) to sort and concatenate duplicates separated by a comma in the adjacent cell to its corresponding number. Then in the right side (of three columns) to count the amount of concatenated numbers in the middle column (if any).
Any help is appreciated.
Please see the spreadsheet to visualize what I'm looking for.
Thanks!
test.xlsx
jcgrooveAsked:
Who is Participating?
 
Rodney EndrigaData AnalystCommented:
jcgroove, this should work as needed: (i adjusted the code a bit)

Sub EE_FindDuplicatesCOUNTIF()
Dim fsCount As Long, ssCount As Long, ssCountIF As Long, cellRow As Long
Dim fsRange As Range, ssRange As Range, strResult As String, cell As Range

fsCount = Range("W4").End(xlDown).Row
ssCount = Range("X4").End(xlDown).Row

Set fsRange = Range("W4:W" & fsCount)
Set ssRange = Range("X4:X" & ssCount)

For Each cell In ssRange
    cell.Select
    ssCountIF = Application.WorksheetFunction.CountIf(ssRange, cell.Value)
    cellRow = fsRange.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True).Row
    Select Case (ssCountIF)
    Case 0: Cells(cellRow, "y").Value = ""
            Cells(cellRow, "z").Value = ""
    Case 1: Cells(cellRow, "y").Value = cell.Value
            Cells(cellRow, "z").Value = ssCountIF
    Case Is > 1: For cv = 1 To ssCountIF
                    strResult = cell.Value & "," & strResult
                 Next cv
                Cells(cellRow, "y").Value = Left(strResult, Len(strResult) - 1)
                Cells(cellRow, "z").Value = ssCountIF
                strResult = ""
    End Select
Next cell
Range("X4:X" & fsCount).Delete shift:=xlToLeft
Range("W4:Y" & fsCount).HorizontalAlignment = xlCenter
Cells(1, "w").Select
End Sub

This assumes your data is in Columns W and X, starting in Row4. The data in Column X will be overwritten with the results.
0
 
Saurabh Singh TeotiaCommented:
You can use the following code..It will do what you are looking for...

Sub compiledata()
    Dim rng As Range, r As Range
    Dim r1 As Range, lrow As Long
    Dim lr As Long, z As Long, v As Long
    Dim str As String, cell As Range

    lrow = Cells(Cells.Rows.Count, "w").End(xlUp).Row
    lr = Cells(Cells.Rows.Count, "x").End(xlUp).Row

    Set rng = Range("W4:W" & lrow)
    Set r = Range("X4:X" & lr)

    For Each cell In rng
        If Application.WorksheetFunction.CountIf(r, cell.Value) > 1 Then

            Set r1 = Range("W3:W" & cell.Row - 1)


            v = Application.WorksheetFunction.CountIf(r, cell.Value)
            For z = 1 To v
                If str = "" Then
                    str = cell.Value
                Else
                    str = str & "," & cell.Value
                End If

            Next z
            cell.Offset(0, 1).Value = str
            cell.Offset(0, 2).Value = v
            str = ""


        ElseIf Application.WorksheetFunction.CountIf(r, cell.Value) = 1 Then
            cell.Offset(0, 1).Value = cell.Value
        Else
            cell.Offset(0, 1).Value = ""

        End If

    Next cell

End Sub

Open in new window


Saurabh....
0
 
jcgrooveAuthor Commented:
That looks like it works but it seems to be deleting some of the values that are in the pre-sorted list. I can have values up to 288. It deleted several inputs.
0
Cloud Class® Course: Microsoft Azure 2017

Azure has a changed a lot since it was originally introduce by adding new services and features. Do you know everything you need to about Azure? This course will teach you about the Azure App Service, monitoring and application insights, DevOps, and Team Services.

 
Saurabh Singh TeotiaCommented:
Can you post your sample file where it deletes..and how you want to see them?
0
 
jcgrooveAuthor Commented:
Here you go!
The "before' tab has the raw data and your code is in the sheet code.
The 'after" tab is what I need it to look like.
Please note there are values down to 288.

Thanks!
test.xlsm
0
 
Rodney EndrigaData AnalystCommented:
jcgroove, this may give you the results you are looking for:


Sub EE_FindDuplicatesCOUNTIF()
Dim fsCount As Long, ssCount As Long, ssCountIF As Long, cellRow As Long
Dim fsRange As Range, ssRange As Range, strResult As String

fsCount = Range("W4").End(xlDown).Row
ssCount = Range("X4").End(xlDown).Row

Set fsRange = Range("W4:W" & fsCount)
Set ssRange = Range("X4:X" & ssCount)

For Each cell In ssRange
    cell.Select
    ssCountIF = Application.WorksheetFunction.CountIf(ssRange, cell.Value)
    cellRow = fsRange.Find(cell.Value, LookIn:=xlFormulas).Row
    Select Case (ssCountIF)
    Case 0: Cells(cellRow, "y").Value = ""
            Cells(cellRow, "z").Value = ""
    Case 1: Cells(cellRow, "y").Value = cell.Value
            Cells(cellRow, "z").Value = ssCountIF
    Case Is > 1: For cv = 1 To ssCountIF
                    strResult = cell.Value & "," & strResult
                Next cv
                Cells(cellRow, "y").Value = strResult
                Cells(cellRow, "z").Value = ssCountIF
                strResult = ""
    End Select
Next cell
Columns("X:X").Delete shift:=xlToLeft
Cells(1, "w").Select
End Sub


This assumes your data is in Columns W and X, starting in Row4. The data in Column X will be overwritten with the results.
0
 
jcgrooveAuthor Commented:
That's nice!
I had to define "cell as range" and "cv as long" variables at the top.
My only problem is that it deleted all the ones at the top of the list!
0
 
Saurabh Singh TeotiaCommented:
Use this version of the code...

Sub compiledata()
    Dim rng As Range, r As Range
    Dim r1 As Range, lrow As Long
    Dim lr As Long, z As Long, v As Long
    Dim str As String, cell As Range

    lrow = Cells(Cells.Rows.Count, "w").End(xlUp).Row
    lr = Cells(Cells.Rows.Count, "x").End(xlUp).Row

    Set rng = Range("W4:W" & lrow)
    Set r = Range("X4:X" & lr)

    For Each cell In rng
        If Application.WorksheetFunction.CountIf(r, cell.Value) > 1 Then

            Set r1 = Range("W3:W" & cell.Row - 1)


            v = Application.WorksheetFunction.CountIf(r, cell.Value)
            For z = 1 To v
                If str = "" Then
                    str = cell.Value
                Else
                    str = str & "," & cell.Value
                End If

            Next z
            cell.Offset(0, 1).Value = str
            cell.Offset(0, 2).Value = v
            str = ""

            Set r1 = Range("X2:X" & cell.Row - 1)
            r1.Replace What:=cell.Value, Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        ElseIf Application.WorksheetFunction.CountIf(r, cell.Value) = 1 Then
            cell.Offset(0, 1).Value = cell.Value
            Set r1 = Range("X2:X" & cell.Row - 1)
            r1.Replace What:=cell.Value, Replacement:="", LookAt:=xlWhole, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
        ElseIf cell.Value > cell.Offset(0, 1).Value Then
            cell.Offset(0, 1).Value = ""

        End If

    Next cell

End Sub

Open in new window


Saurabh...
0
 
jcgrooveAuthor Commented:
I may have been a bit too hasty.
I didn't foresee that the unsorted list in column X may be longer than the 1-288 index in column w.
Both solutions above do not go past 288 in either column.
Please help!
test.xlsm
0
 
Saurabh Singh TeotiaCommented:
Jcgroove..

One last question i have from you that..can this be ever happen that their a value in x column which is not their in W Column??

Saurabh...
0
 
jcgrooveAuthor Commented:
No, that should not happen.
Thanks!
0
 
Saurabh Singh TeotiaCommented:
Their you go use this code this will do what you are looking for..

Sub combinedata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rng As Range, lrow As Long
    Dim r As Range, lr As Long, cell As Range
    Dim ws As Worksheet, ws1 As Worksheet
    Dim r1 As Range

    Set ws = ActiveSheet

    lrow = ws.Cells(Cells.Rows.Count, "w").End(xlUp).Row
    lr = ws.Cells(Cells.Rows.Count, "x").End(xlUp).Row

    Set rng = ws.Range("W4:W" & lrow)
    Set r = ws.Range("x4:x" & lr)

    Sheets.Add After:=Sheets(Sheets.Count)
    Set ws1 = ActiveSheet

    rng.Copy ws1.Range("A1")
    r.Copy ws1.Range("B1")

    lrow = ws1.Cells(Cells.Rows.Count, "a").End(xlUp).Row
    lr = ws1.Cells(Cells.Rows.Count, "b").End(xlUp).Row

    Set rng = ws1.Range("A1:A" & lrow)
    Set r = ws1.Range("B1:B" & lr)

    For Each cell In r

        If Trim(cell.Value) <> "" Then


            Set r1 = rng.Find(What:=cell.Value, After:=Cells(1, 1), LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, SearchFormat:=False)
            If r1.Offset(0, 2).Value = "" Then
                r1.Offset(0, 2).Value = cell.Value
            Else
                r1.Offset(0, 2).Value = r1.Offset(0, 2).Value & "," & cell.Value
            End If
            If Application.WorksheetFunction.CountIf(r, cell.Value) > 1 Then r1.Offset(0, 3).Value = r1.Offset(0, 3).Value + 1
            Set r1 = Nothing

        End If


    Next cell

    ws1.Columns("B:B").Delete
    lrow = ws1.Cells(Cells.Rows.Count, "a").End(xlUp).Row

    ws1.Range("A1:C" & lrow).Copy ws.Range("W4")
    ws1.Delete
    ws.Cells.EntireColumn.AutoFit


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Open in new window


Saurabh...
0
 
Saurabh Singh TeotiaCommented:
Does this code takes care of what you are looking for??
0
 
jcgrooveAuthor Commented:
Can this be done using columns AA and AB of the same worksheet instead of another worksheet?
0
 
Saurabh Singh TeotiaCommented:
Their you go use this code..I'm using AA and AB Column in this case..

Sub combinedata()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Dim rng As Range, lrow As Long
    Dim r As Range, lr As Long, cell As Range
    Dim ws As Worksheet, ws1 As Worksheet
    Dim r1 As Range

    Set ws = ActiveSheet

    lrow = ws.Cells(Cells.Rows.Count, "w").End(xlUp).Row
    lr = ws.Cells(Cells.Rows.Count, "x").End(xlUp).Row

    Set rng = ws.Range("W4:W" & lrow)
    Set r = ws.Range("x4:x" & lr)



    For Each cell In r

        If Trim(cell.Value) <> "" Then


            Set r1 = rng.Find(What:=cell.Value, After:=Cells(4, 23), LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, SearchFormat:=False)
            If r1.Offset(0, 3).Value = "" Then
                r1.Offset(0, 3).Value = cell.Value
            Else
                r1.Offset(0, 3).Value = r1.Offset(0, 3).Value & "," & cell.Value
            End If
            If Application.WorksheetFunction.CountIf(r, cell.Value) > 1 Then r1.Offset(0, 4).Value = r1.Offset(0, 4).Value + 1
            Set r1 = Nothing

        End If


    Next cell


    ws.Cells.EntireColumn.AutoFit


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub

Open in new window


Saurabh...
0
 
jcgrooveAuthor Commented:
Thanks! That worked!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.