Sort, concatenate and count column data

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

Select allOpen in new window

Saurabh....

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.

Can you post your sample file where it deletes..and how you want to see them?

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

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.

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!

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

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

No, that should not happen.
Thanks!

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

Select allOpen in new window

Saurabh...

Does this code takes care of what you are looking for??

Can this be done using columns AA and AB of the same worksheet instead of another worksheet?

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

Select allOpen in new window

Saurabh...

Thanks! That worked!