Create a new column for each unique item in a list with VBA?

[teamswank]

Hi -

I have a list of partnerships like this on Sheet2:

For each uniquely named partnership, I would like it to take that name and copy a "template" column I will provide but with the partnership name as the header in a table on Sheet1. My table looks like this:

So that in the end, each partnership would represent a column on my worksheet.

This seems like it would be a common request, but I have looked online, but cannot seem to find anything that mirrors it. Please point me in that direction if you do.

Thank you.

 

[Trebor76]

Hi teamswank,

Welcome to MrExcel!!

Try this:

Option Explicit
Sub Macro1()

    Dim wsSource As Worksheet, wsOutput As Worksheet
    Dim lngMyRow As Long, lngLastRow As Long, lngMyCounter As Long
    Dim lngOutputCol As Long
    Dim clnUniquePshp As New Collection
   
    Application.ScreenUpdating = False
   
    Set wsSource = ThisWorkbook.Sheets("Sheet2")
    Set wsOutput = ThisWorkbook.Sheets("Sheet1")
    lngLastRow = wsSource.Cells(Rows.Count, "A").End(xlUp).Row
    lngOutputCol = 3 'Initial output column (C in this case). Change to suit.
   
    For lngMyRow = 2 To lngLastRow
        On Error Resume Next
            clnUniquePshp.Add wsSource.Range("A" & lngMyRow), CStr(wsSource.Range("A" & lngMyRow)) 'Assumes the partnership names are in Col. A of 'wsSource'. Change to suit.
            If Err.Number = 0 Then
                wsOutput.Cells(1, lngOutputCol).Value = wsSource.Range("A" & lngMyRow)
                lngOutputCol = lngOutputCol + 1
                lngMyCounter = lngMyCounter + 1
            End If
        On Error GoTo 0
    Next lngMyRow

    Application.ScreenUpdating = True
   
    If lngMyCounter = 0 Then
        MsgBox "There were no unique partnerships found in """ & wsSource.Name & """ to be copied to """ & wsOutput.Name & ".", vbExclamation
    Else
        MsgBox Format(lngMyCounter, "#,##0") & " unique partnership(s) have now been copied from """ & wsSource.Name & """ to""" & wsOutput.Name & ".", vbInformation
    End If

End Sub

Regards,

Robert

 

[Peter_SSs]

So that in the end, each partnership would represent a column on my worksheet.

So, do you mean the first name would go in that blue cell you have shown, second name in the cell to the right of the blue one etc?
If so, do you really need a macro? Could you just put this formula (check table name and column header name) into the blue cell of your template sheet?

BTW, I suggest that you investigate XL2BB for providing sample data to make it easier for helpers by not having to manually type out sample data to test with. Then you won't get simplified data like this?

teamswank.xlsm
	C
1	PshpName
2	Name 1
3	Name 1
4	Name 1
5	Name 1
6	Name 1
7	Name 2
8	Name 2
9	Name 3
10	Name 3
11	Name 3
12	Name 3
13	Name 3
14	Name 3
Sheet2

teamswank.xlsm
	B	C	D	E
1		Name 1	Name 2	Name 3
2	1
3	2
4	3
5	4a
6	4b
Sheet1

Cell Formulas
Range	Formula
C1:E1	C1	=TRANSPOSE(UNIQUE(Table1[PshpName]))
Dynamic array formulas.