Group List by Values in Column A and combine related row values inColumn B into 1 Cell

[srusskinyon]

Basically, I need a system to group a list of suppliers in column A and then merge needs that match them into single cells in column b.

I have a list of suppliers and needs. It looks like this:

Current List
Column A Column B
Supplier 1 Need 1
Supplier 1 Need 2
Supplier 1 Need 3
Supplier 2 Need 4
Supplier 2 Need 5
Supplier 3 Need 6
Supplier 3 Need 7
Supplier 3 Need 8
Supplier 4 Need 9
Supplier 5 Need 10
Supplier 5 Need 10

I want to end up with this: (Needs combined into one cell by supplier, each need on a new line)

Column A Column B
Supplier 1 Need 1 (Combined into one cell, each need on a new line)
Need 2
Need 3
Supplier 2 Need 4
Need 5
Supplier 3 Need 6
Need 7
Need 8
Supplier 4 Need 9
Supplier 5 Need 10
Need 10


Any help is very appreciated!

 

[srusskinyon]

On Tuesday, June 17, 2014 11:42:23 AM UTC-4, (e-mail address removed) wrote:

I should also mention that I am using Office 2011 for Mac

 

[Claus Busch]

Hi,

Am Tue, 17 Jun 2014 08:42:23 -0700 (PDT) schrieb (e-mail address removed):

Current List
Column A Column B
Supplier 1 Need 1
Supplier 1 Need 2
Supplier 1 Need 3
Supplier 2 Need 4
Supplier 2 Need 5
Supplier 3 Need 6
Supplier 3 Need 7
Supplier 3 Need 8
Supplier 4 Need 9
Supplier 5 Need 10
Supplier 5 Need 10

try (modify the sheet names):

Sub TransposeTable()
Dim arrIn As Variant, myArr As Variant, arrUnique As Variant
Dim arrOut() As Variant
Dim myDic As Object
Dim myStr As String
Dim LRow As Long, i As Long, j As Long, n As Long

With Sheets("Sheet1")
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
myArr = .Range("A1:A" & LRow)
arrIn = .Range("A1:B" & LRow)
Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(myArr) To UBound(myArr)
myDic(myArr(i, 1)) = myArr(i, 1)
Next
arrUnique = myDic.items

Sheets("Sheet2").Range("A1").Resize(rowsize:=myDic.Count) _
= Application.Transpose(arrUnique)

For j = LBound(arrUnique) To UBound(arrUnique)
myStr = ""
For i = LBound(arrIn) To UBound(arrIn)
ReDim Preserve arrOut(myDic.Count - 1)
If arrIn(i, 1) = arrUnique(j) Then
myStr = myStr & arrIn(i, 2) & Chr(10)
End If
Next
arrOut(n) = Left(myStr, Len(myStr) - 1)
n = n + 1
Next
Sheets("Sheet2").Range("B1").Resize(rowsize:=myDic.Count) _
= Application.Transpose(arrOut)
End With

End Sub

Regards
Claus B.

 

[srusskinyon]

Claus,

Thank you so much!

I have an additional question:

If I were to add an additional column so my data looks like:

Column A Column B Column C
Supplier 1 Buyer 1 Need 1
Supplier 1 Buyer 1 Need 2
Supplier 1 Buyer 1 Need 3
Supplier 1 Buyer 2 Need 1
Supplier 1 Buyer 2 Need 2
Supplier 2 Buyer 1 Need 1
Supplier 2 Buyer 1 Need 5
Supplier 2 Buyer 3 Need 7


And I'm looking for:

Supplier 1 Buyer 1 Need 1
Need 2
Need 3
Supplier 1 Buyer 2 Need 1
Need 2
Supplier 2 Buyer 1 Need 1
Need 5
Supplier 2 Buyer 3 Need 7

This returns the needs by buyer, but from data filtered by supplier in column A. This is key because the buyers may relate to multiple suppliers.

Thanks!

 

[Claus Busch]

Hi,

Am Tue, 17 Jun 2014 10:15:45 -0700 (PDT) schrieb (e-mail address removed):

If I were to add an additional column so my data looks like:

Column A Column B Column C
Supplier 1 Buyer 1 Need 1
Supplier 1 Buyer 1 Need 2
Supplier 1 Buyer 1 Need 3
Supplier 1 Buyer 2 Need 1
Supplier 1 Buyer 2 Need 2
Supplier 2 Buyer 1 Need 1
Supplier 2 Buyer 1 Need 5
Supplier 2 Buyer 3 Need 7

for the following code your table in Sheet1 needs headers:

Sub TransposeTable2()
Dim LRow As Long
Dim arrCheck As Variant, arrIn As Variant, arrOut() As Variant
Dim myStr As String
Dim i As Long, j As Long, n As Long
Dim LRow2 As Long

With Sheets("Sheet1")
LRow = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A1:B" & LRow).AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheets("Sheet2").Range("A1"), Unique:=True

arrIn = .Range("A2:C" & LRow)
arrCheck = Sheets("Sheet2").Range("A2:B" & Cells(Rows.Count,
1).End(xlUp).Row)
LRow2 = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

For j = LBound(arrCheck) To UBound(arrCheck)
myStr = ""
For i = LBound(arrIn) To UBound(arrIn)
If arrIn(i, 1) = arrCheck(j, 1) And arrIn(i, 2) =
arrCheck(j, 2) Then
myStr = myStr & arrIn(i, 3) & Chr(10)
End If
Next
ReDim Preserve arrOut(LRow2 - 2)
arrOut(n) = Left(myStr, Len(myStr) - 1)
n = n + 1
Next
Sheets("Sheet2").Range("C2").Resize(UBound(arrOut) + 1) _
= Application.Transpose(arrOut)
End With
End Sub


Regards
Claus B.

 

[srusskinyon]

Claus,

Thank you for this! I ran the macro and it returns in Sheet2 the data in Column A and Column B, but nothing in Column C. I also get the error message, "Run-time Error '5': Invalid procedure call or argument."

 

[Claus Busch]

Hi,

Am Tue, 17 Jun 2014 11:40:14 -0700 (PDT) schrieb (e-mail address removed):

Thank you for this! I ran the macro and it returns in Sheet2 the data in Column A and Column B, but nothing in Column C. I also get the error message, "Run-time Error '5': Invalid procedure call or argument."

please have a look:
https://onedrive.live.com/?cid=9378...#cid=9378AAB6121822A3&id=9378AAB6121822A3!326
for "TransposeTable"
You have to rightclick and download the file because macros are disabled
in OneDrive
If this file is also not working there is a difference between Excel for
Mac and Excel for Windows that I don't know.


Regards
Claus B.

 

[srusskinyon]

It seems to be tripping on this line:


Set myDic = CreateObject("Scripting.Dictionary")

This could be a Mac issue, I'm not sure.