Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations strongm on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Concatenate Duplicates 2

Status
Not open for further replies.
Omnicube

Omnicube

MIS
Nov 7, 2011
40
US
Hi Guys,

I am looking to concatenate duplicates in my worksheet. I looked at the concatenate code samples using the search feature, but I was unable to locate anything that directly applied to my situation. Example below:

Existing Table
Column A Column B
987654321 a
987654321 b
987654321 c
123456789 d
654987321 e
654987321 f
654987321 g

I would like my new table to look like this:

Column A Column B
987654321 a, b, c
123456789 d
654987321 e, f, g

If someone could point me in the right direction, I would appreciate it. [2thumbsup]
 
Sort by date Sort by votes



hi,

What code do you have so far? Where are you stuck?

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
I have a Module in Access that does it for me currently, but I am looking to complete the action in Excel.

I tried to modify Hookom's code to satisfy my needs, but I was unable to do so successfully.

Here is the Access Module if you wanted to see it.

Code: 
Option Compare Database


Function UpdateAmounts() As Boolean


    Dim db As Database
    Dim tdf As TableDef
    Dim fld As Field
    Dim rst As Recordset
    Dim strSQL As String
    
    Dim db1 As Database
    Dim tdf1 As TableDef
    Dim fld1 As Field
    Dim rst1 As Recordset
    Dim strSQL1 As String
    
    Dim strTableName As String
    Dim strTableName1 As String
    
    Dim Delimiter As String
    
    
    ReDim SubStrs(0) As String
    Dim CurPos As Long
    Dim NextPos As Long
    Dim DelLen As Integer
    Dim nCount As Integer
    Dim xCount As Integer
    Dim TStr As String
    Dim sortkeylast As String
    Dim sortkeynext As String
    Dim servernamesCSV As String
        
    
    strTableName = "at"
    strTableName1 = "at1"
    Delimiter = ", "
        
    
    Set db = CurrentDb()
    Set db1 = CurrentDb()
    
    On Error GoTo Err_Execute

    
    Set rst1 = db1.OpenRecordset(strTableName1, dbOpenTable)
    
    
readfirst:

Set rst = db.OpenRecordset(strTableName, dbOpenTable)
rst.Index = "f1"
    
    rst.MoveFirst
        
    sortkeylast = rst![f2]
    
    nCount = 1
    
    rst1.AddNew
            
    rst1![f1] = rst![f1]
    rst1![f2] = rst![f2]
    rst1![f3] = rst![f3]
    rst1![f4] = rst![f4]
    rst1![f5] = rst![f5]
    rst1![f6] = rst![f6]
    rst1![f7] = rst![f7]
    rst1![f8] = rst![f8]
    rst1![f9] = rst![f9]
    rst1![f10] = rst![f10]
    rst1![f11] = rst![f11]
    rst1![f12] = rst![f12]
    rst1![f13] = rst![f13]
    rst1![f14] = rst![f14]
    rst1![f15] = rst![f15]
    rst1![f16] = rst![f16]
    rst1![f17] = rst![f17]
    rst1![f18] = rst![f18]
    rst1![f19] = rst![f19]
    rst1![f20] = rst![f20]
    rst1![f21] = rst![f21]
    rst1![f22] = rst![f22]
    rst1![f23] = rst![f23]
    rst1![f24] = rst![f24]
    servernamesCSV = rst![f25]
    rst1![f26] = rst![f26]
    rst1![f27] = rst![f27]
    rst1![f28] = rst![f28]
    rst1![f29] = rst![f29]
    rst1![f30] = rst![f30]
    rst1![f31] = rst![f31]
    rst1![f32] = rst![f32]
    rst1![f33] = rst![f33]
    rst1![f34] = rst![f34]
    rst1![f35] = rst![f35]
    rst1![f36] = rst![f36]
    rst1![f37] = rst![f37]
    rst1![f38] = rst![f38]
    rst1![f39] = rst![f39]
    rst1![f40] = rst![f40]
    rst1![f41] = rst![f41]
    rst1![f42] = rst![f42]
    rst1![f43] = rst![f43]
    rst1![f44] = rst![f44]
    rst1![f45] = rst![f45]
    rst1![f46] = rst![f46]
    rst1![f47] = rst![f47]
        
Do Until rst.EOF

    rst.MoveNext
    
    If rst.EOF Then GoTo readnext:
    
    sortkeynext = rst![f2]
    
    If sortkeylast <> sortkeynext Then GoTo sortbreak:
    
    If Len(Trim(rst![f25])) > 0 Then servernamesCSV = servernamesCSV & Delimiter & Trim(rst![f25])
    
    nCount = nCount + 1
    
    GoTo readnext:
sortbreak:

rst1![f25] = servernamesCSV
rst1![f40] = nCount
rst1![f2] = sortkeylast
rst1.Update
sortkeylast = sortkeynext
rst1.AddNew
    rst1![f1] = rst![f1]
    rst1![f2] = rst![f2]
    rst1![f3] = rst![f3]
    rst1![f4] = rst![f4]
    rst1![f5] = rst![f5]
    rst1![f6] = rst![f6]
    rst1![f7] = rst![f7]
    rst1![f8] = rst![f8]
    rst1![f9] = rst![f9]
    rst1![f10] = rst![f10]
    rst1![f11] = rst![f11]
    rst1![f12] = rst![f12]
    rst1![f13] = rst![f13]
    rst1![f14] = rst![f14]
    rst1![f15] = rst![f15]
    rst1![f16] = rst![f16]
    rst1![f17] = rst![f17]
    rst1![f18] = rst![f18]
    rst1![f19] = rst![f19]
    rst1![f20] = rst![f20]
    rst1![f21] = rst![f21]
    rst1![f22] = rst![f22]
    rst1![f23] = rst![f23]
    rst1![f24] = rst![f24]
    servernamesCSV = rst![f25]
    nCount = 1
    rst1![f26] = rst![f26]
    rst1![f27] = rst![f27]
    rst1![f28] = rst![f28]
    rst1![f29] = rst![f29]
    rst1![f30] = rst![f30]
    rst1![f31] = rst![f31]
    rst1![f32] = rst![f32]
    rst1![f33] = rst![f33]
    rst1![f34] = rst![f34]
    rst1![f35] = rst![f35]
    rst1![f36] = rst![f36]
    rst1![f37] = rst![f37]
    rst1![f38] = rst![f38]
    rst1![f39] = rst![f39]
    rst1![f40] = rst![f40]
    rst1![f41] = rst![f41]
    rst1![f42] = rst![f42]
    rst1![f43] = rst![f43]
    rst1![f44] = rst![f44]
    rst1![f45] = rst![f45]
    rst1![f46] = rst![f46]
    rst1![f47] = rst![f47]
readnext:
    
Loop
    
writelast:

rst1![f25] = servernamesCSV
rst1![f40] = nCount

rst1.Update

    rst.Close
    rst1.Close
    Set rst = Nothing
    Set rst1 = Nothing
    Set db = CurrentDb()
    Set db1 = CurrentDb()

    UpdateAmounts = True
    
    On Error GoTo 0

    Exit Function

Err_Execute:
    UpdateAmounts = False

 End Function
 
Upvote 0 Downvote


you can do the same thing in Excel, querying MS Access, using ActiveX Data Objects.

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
Thanks for the suggestion! Unfortunately, I am trying to phase out MS Access of the process.

I found this code online, and it seems to do what I need. I am really confused as to how it works. I was able to modify where the new values print etc, but I was wondering if you could help me understand how it works.

Code: 
Sub Macro1()

  Dim C As Long
  Dim Cell As Range
  Dim Data As String
  Dim DSO As Object
  Dim Key As Variant
  Dim Keys As Variant
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  
    Set Rng = Range("A2")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    Set Rng = IIf(RngEnd.Row < Rng.Row, Rng, Range(Rng, RngEnd))
    
    Set DSO = CreateObject("Scripting.Dictionary")
    
      For Each Cell In Rng
        If Not DSO.Exists(Cell.Value) Then
           DSO.Add Cell.Value, Cell.Offset(0, 5).Value
        Else
           Data = DSO(Cell.Value)
           DSO(Cell.Value) = Data & ", " & Cell.Offset(0, 5).Value
        End If
      Next Cell
      
      Keys = DSO.Keys
      R = Rng.Row
      C = Rng.Column + 7
      'Rng.Resize(Columnsize:=2).ClearContents
      
        For Each Key In Keys
          Cells(R, C) = Key
          Cells(R, C + 1) = DSO(Key)
          R = R + 1
        Next Key
        
    Set DSO = Nothing
    
End Sub
 
Upvote 0 Downvote


okay.

1) what is the sheet/range of your source list?

2) where do you want the results (sheet/first cell)?

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
1) Sheet = Sheet1
Range1 = Duplicate Values Column A
Range2 = Corresponding values tied to one value in column A (primary key for a lack of a better term)

2) Output to Sheet2 would be awesome if I could do that cell A2
 
Upvote 0 Downvote


Run with Sheet1 active
Code: 
Sub Main()
    Dim r As Range, sPrev As String, lRow As Long, iCol As Integer, sOUT As String
'this controls the row & column on Sheet2
    lRow = 1
    iCol = 1
    
    For Each r In Range([A2], [A2].End(xlDown))
        If sPrev <> r.Value Then
            If sOUT <> "" Then GoSub LoadIt
            lRow = lRow + 1
            With Sheets("Sheet2").Cells(lRow, iCol)
                .NumberFormat = "@"
                .Value = r.Value
            End With
            sPrev = r.Value
            sOUT = ""
        End If
        sOUT = sOUT & r.Offset(0, 1).Value & ","
    Next
    If sOUT <> "" Then GoSub LoadIt
    Exit Sub
    
LoadIt:
    Sheets("Sheet2").Cells(lRow, iCol + 1).Value = Left(sOUT, Len(sOUT) - 1)
    Return
End Sub

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
Thanks skip. Works exactly as I needed it to.

Can you help me understand sPrev, sOUT, and the @ number format?
 
Upvote 0 Downvote


sPrev is the previous value in column A. When the current value is not equal to the previous value, then the accumulated values, sOut, are output.

The @ number format is TEXT. Otherwise, Excel wants to treat the column A values a numbers and displays them as scientific notation.

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
Thanks a bunch for the explanation.

I noticed that after the code executes it adds a "," after the last concatenated field.

i.e. the values look like the below table


Column A Column B
Record 1 a, b, c,

Is there a way to get rid of the comma after the "c"?

Thanks,
 
Upvote 0 Downvote


When I run the code that I sent you, here is the B4...
[tt]
cola colb
987654321 a
987654321 b
987654321 c
123456789 d
654987321 e
654987321 f
654987321 g
[/tt]
and after
[tt]
987654321 a,b,c
123456789 d
654987321 e,f,g
[/tt]

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
The only thing that I changed was

Code: 
sOUT = sOUT & r.Offset(0, 1).Value & ", "

I added a space after the "," for easier reading of the new values.

Is this not a good way to accomplish my goal?
 
Upvote 0 Downvote
Also, what if I wanted to take more columns from the original sheet?

Would I just add more statements to the 'with' portion of the code? I have a situation where I need to move 40+ columns of data. That seems like a lot of statements. of .Cells(lRow, iCol + 1) statements (if that's how ya do it). :)

 
Upvote 0 Downvote


You should have originally stated that you CHANGED the code that I sent you!
Code: 
LoadIt:
    Sheets("Sheet2").Cells(lRow, iCol + 1).Value = Left(sOUT, Len(sOUT) - [highlight]2[/highlight])
    Return

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
You're right! That's an important thing to mention! Won't happen again, my apologies.

Your help has been invaluable!

What do you think about the extra columns question?
 
Upvote 0 Downvote


Also, what if I wanted to take more columns from the original sheet?
Click to expand...
Exactly what does that mean?

Post an example of the 'more columns' and what you expect to see are a result, along with a statement of the logic to accomplish.

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
I would also like to use this code to transfer more than just two columns we are comparing.

i.e.
Before Code
Column 1 Column 2 Column 3 Column 4 Column 5 ...
123456 a asdf qwer zxcv
123456 b asdf qwer zxcv
789456 c fdas rewq vcxz
789456 d fdas rewq vcxz

After code
Column 1 Column 2 Column 3 Column 4 Column 5 ...
123456 a, b asdf qwer zxcv
789456 c, d fdas rewq vcxz
 
Upvote 0 Downvote


okay, give this a try...
Code: 
Sub Main()
    Dim r As Range, c As Range, sPrev As String, lRow As Long, iCol As Integer, sOUT() As String, i As Integer
    Const SEP = ", "
'this controls the row & column on Sheet2
    lRow = 1
    
    i = [A2].CurrentRegion.Columns.Count - 2
    ReDim sOUT(i)
    
    For Each r In Range([A2], [A2].End(xlDown))
        If sPrev <> r.Value Then
            If sOUT(0) <> "" Then GoSub LoadIt
            lRow = lRow + 1
            iCol = 1
            With Sheets("Sheet2").Cells(lRow, iCol)
                .NumberFormat = "@"
                .Value = r.Value
            End With
            sPrev = r.Value
            For i = 0 To UBound(sOUT)
                sOUT(i) = ""
            Next
        End If
        For Each c In Range([b2], [b2].End(xlToRight))
            With c
                iCol = .Column
                sOUT(iCol - 2) = sOUT(iCol - 2) & Cells(r.Row, .Column).Value & SEP
            End With
        Next
    Next
    If sOUT(0) <> "" Then GoSub LoadIt
    Exit Sub
    
LoadIt:
    For iCol = 0 To UBound(sOUT)
        Sheets("Sheet2").Cells(lRow, iCol + 2).Value = Left(sOUT(iCol), Len(sOUT(iCol)) - Len(SEP))
    Next
    Return
End Sub

Skip,
[sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
Thanks again for the help!

I ran the code without any edits, and the following was produced:
A B C D E
123456 a, b asdf, asdf qwer, qwer zxcv, zxcv
789456 c, d fdas, fdas rewq, rewq vcxz, vcxz

If the values in column C - E are the same, I would like them to stay static instead of concatenate like column B.

 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

Eitel13
  • Locked
  • Question
VBA - Remove Duplicates Across Multiple Sheets in Workbook
Replies
2
Views
91
Eitel13
Eitel13
Thadius
  • Locked
  • Question
Preventing Duplicates
Replies
12
Views
58
Andrzejek
Andrzejek
OMG_VBA_IS_GREAT
  • Locked
  • Question
Delete Duplicates takes over 3 hours to complete
Replies
2
Views
48
DjangMan
DjangMan
zoodaddy
  • Locked
  • Question
Find duplicates in a column and change text color
Replies
6
Views
109
SkipVought
S
Bluejay07
  • Locked
  • Question
Excel 2007 Concatenate column 1
Replies
3
Views
39
Bluejay07
Bluejay07

Part and Inventory Search

Sponsor

Back
Top