The CompTIA Cloud+ Basic training course will teach you about cloud concepts and models, data storage, networking, and network infrastructure.

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

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

Experts Exchange Solution brought to you by

Enjoy your complimentary solution view.

Get every solution instantly with Premium.
Start your 7-day free trial.

I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

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

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

ssCount = Range("X4").End(xlDown).Ro

Set fsRange = Range("W4:W" & fsCount)

Set ssRange = Range("X4:X" & ssCount)

For Each cell In ssRange

cell.Select

ssCountIF = Application.WorksheetFunct

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.

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!

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

Saurabh...

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

ssCount = Range("X4").End(xlDown).Ro

Set fsRange = Range("W4:W" & fsCount)

Set ssRange = Range("X4:X" & ssCount)

For Each cell In ssRange

cell.Select

ssCountIF = Application.WorksheetFunct

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

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.

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trialI 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

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

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

Saurabh...

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

Saurabh...

Microsoft Excel

From novice to tech pro — start learning today.

Experts Exchange Solution brought to you by

Enjoy your complimentary solution view.

Get every solution instantly with Premium.
Start your 7-day free trial.

Open in new window

Saurabh....