merge rows in two column-one word multi meaning -macro

[osmanoca]

hello friends..
i have a dictionary data in excel with two columns. A is word and B ise meaning. But some rows are same in column A, but meaning in B are different meanings. so i want to merge all in one row. it will be one word and multi meaning with comma
. i want macro please. thanks thanks from now....


Example:
A B

Abadîn	Ölmez
Abadîn	Bengi
Abadîn	Ebedî
Abadîn	Kalıcı

<tbody>
</tbody>

i want them to be so with comma one row: (two columns, one row)

A.....................................B

<tbody>
</tbody>

Abadîn .............................Ölmez, Bengi, Ebedî, Kalıcı

 

[MrKowz]

This is untested, but give this a shot.

Public Sub ConsolidateDictionary()
Dim i       As Long, _
    LR      As Long
    
Dim d       As Object, _
    k       As Variant
    
Dim rowx    As Long
    
Dim sWS     As Worksheet, _
    dWS     As Worksheet
    
Set sWS = activeworksheet
Set dWS = Sheets.Add

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

LR = sWS.Range("A" & Rows.count).End(xlUp).Row
Set d = CreateObject("Scripting.Dictionary")

For i = 1 To LR
    If Not d.exists(sWS.Range("A" & i).Value) Then
        'Value not in list, add meaning and first definition to list
        d.Add sWS.Range("A" & i).Value, sWS.Range("B" & i).Value
    Else
        'Value exists, append definition to meaning
        d(sWS.Range("A" & i).Value) = d(sWS.Range("A" & i).Value) & ", " & sWS.Range("B" & i).Value
    End If
Next i

rowx = 1
For Each k In d.keys
    dWS.Range("A" & rowx).Value = k
    dWS.Range("B" & rowx).Value = d(k)
    rowx = rowx + 1
Next k

dWS.Activate

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

 

[ask2tsp]

hello osmanoca.
Is data sorted by column A?

 

[osmanoca]

Sorry didint work, giving error..thanks again..

This is untested, but give this a shot.

Public Sub ConsolidateDictionary()
Dim i       As Long, _
    LR      As Long
    
Dim d       As Object, _
    k       As Variant
    
Dim rowx    As Long
    
Dim sWS     As Worksheet, _
    dWS     As Worksheet
    
Set sWS = activeworksheet
Set dWS = Sheets.Add

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With

LR = sWS.Range("A" & Rows.count).End(xlUp).Row
Set d = CreateObject("Scripting.Dictionary")

For i = 1 To LR
    If Not d.exists(sWS.Range("A" & i).Value) Then
        'Value not in list, add meaning and first definition to list
        d.Add sWS.Range("A" & i).Value, sWS.Range("B" & i).Value
    Else
        'Value exists, append definition to meaning
        d(sWS.Range("A" & i).Value) = d(sWS.Range("A" & i).Value) & ", " & sWS.Range("B" & i).Value
    End If
Next i

rowx = 1
For Each k In d.keys
    dWS.Range("A" & rowx).Value = k
    dWS.Range("B" & rowx).Value = d(k)
    rowx = rowx + 1
Next k

dWS.Activate

With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

 

[osmanoca]

yes, basic column is A. other column ise meaning.

hello osmanoca.
Is data sorted by column A?

 

[osmanoca]

thanks to all. i found this code from a friend. this will show the result in C and D columns.

Option Explicit

Sub ANLAMLARI_BİRLEŞTİR()
Dim Son As Long, X As Long, Kelime As Variant, Say As Long, Satir As Long

Application.ScreenUpdating = False

Son = Cells(Rows.Count, 1).End(3).Row
Range("C:D").ClearContents
Satir = 1

For X = 1 To Son
Kelime = Cells(X, 1).Value
Say = WorksheetFunction.CountIf(Range("A:A"), Kelime)
Select Case Say
Case 1
Cells(Satir, 3) = Kelime
Cells(Satir, 4) = Cells(X, 2)
Case Is > 1
Cells(Satir, 3) = Kelime
Cells(Satir, 4) = Join(Application.Transpose(Range(Cells(X, 2), Cells(X + Say - 1, 2))), ", ")
End Select
X = X + Say - 1
Satir = Satir + 1
Next

Range("C:D").EntireColumn.AutoFit

Application.ScreenUpdating = True

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[hiker95]

osmanoca,

Please see your other, original duplicate post, for another macro solution:

https://www.mrexcel.com/forum/excel...ame-rows-merging-other-column-rows-macro.html

 

[hiker95]

osmanoca,

Here is my macro solution from your other thread/post.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub MergeMyData()
' hiker95, 07/22/2017, ME1015455
Dim rng As Range, c As Range
Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In rng
    If Not .Exists(c.Value) Then
      .Add c.Value, c.Offset(, 1)
    Else
      .Item(c.Value) = .Item(c.Value) & ", " & c.Offset(, 1)
    End If
  Next
  rng.Resize(, 2).ClearContents
  Range("A1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
End With
Cells.EntireColumn.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the MergeMyData macro.

 

[osmanoca]

Thanks dear hiker95, ok, solved.

osmanoca,

Here is my macro solution from your other thread/post.

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub MergeMyData()
' hiker95, 07/22/2017, ME1015455
Dim rng As Range, c As Range
Set rng = Range(Range("A1"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("Scripting.Dictionary")
  .CompareMode = vbTextCompare
  For Each c In rng
    If Not .Exists(c.Value) Then
      .Add c.Value, c.Offset(, 1)
    Else
      .Item(c.Value) = .Item(c.Value) & ", " & c.Offset(, 1)
    End If
  Next
  rng.Resize(, 2).ClearContents
  Range("A1").Resize(.Count, 2) = Application.Transpose(Array(.Keys, .Items))
End With
Cells.EntireColumn.AutoFit
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the MergeMyData macro.

 

[hiker95]

Thanks dear hiker95, ok, solved.

osmanoca,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.