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

  • Thread starter Thread starter srusskinyon
  • Start date Start date
S

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!
 
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
 
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
Click to expand...

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.
 
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!
 
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
Click to expand...

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.
 
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."
 
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."
Click to expand...


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.
 
It seems to be tripping on this line:


Set myDic = CreateObject("Scripting.Dictionary")

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