Summarizing Data from 2 columns into Rows

[Jamzag]

Hello All,

Newbie here so take it easy!

I have a lengthy list of data (~500 lines) that has 2 columns with where names appear multiple times if the person has more than one sector of access. I would like to segment my data into rows. See below for an example. Thanks in advance...

COLUMN A	COLUMN B	COLUMN C	COLUMN D	COLUMN E	COLUMN F
Existing Format
Name	ID#	Access
John Smith	3	HQ
Jane Doe	21	HQ
Jane Doe	21	ISC
Jane Doe	21	Finance
Mike Thomas	34	Finance
Mike Thomas	34	ISC
John James	7	ISC
Sam Smith	12	Finance
Preferred Format
Name	ID#	Access1	Access2	Access3	Access4
John Smith	3	HQ
Jane Doe	21	HQ	ISC	Finance
Mike Thomas	34	Finance	ISC
Sam Smith	12	Finance
John James	7	ISC

<tbody>
</tbody>

 

[alansidman]

Perhaps a Pivot Table.

v	A	B	C	D	E	F	G	H	I	J	K
1	Name	ID#	Access			Count of Access		Access
2	John Smith	3	HQ			Name	ID#	Finance	HQ	ISC
3	Jane Doe	21	HQ			Jane Doe
4	Jane Doe	21	ISC				21	1	1	1
5	Jane Doe	21	Finance			John James
6	Mike Thomas	34	Finance				7			1
7	Mike Thomas	34	ISC			John Smith
8	John James	7	ISC				3		1
9	Sam Smith	12	Finance			Mike Thomas
10							34	1		1
11						Sam Smith
12							12	1
13

 

[JoeMo]

Welcome to the Forum!

Here's a macro that will rearrange your data, assumed to start with the header "Name" in cell A1, beginning in cell F1. The macro can easily be adapted if needed to insert rows for the rearranged data or place it somewhere else.

Sub jamzag()
Dim R As Range, V1 As Variant, Unq As Long, V2 As Variant, i As Long, j As Long, Vout As Variant, ct As Long
Set R = Range("A1").CurrentRegion
Application.ScreenUpdating = False
R.Columns(1).Resize(, 2).AdvancedFilter Action:=xlFilterCopy, copytorange:=[F1], unique:=True
Unq = Evaluate("SUMPRODUCT((" & R.Columns(3).Address(0, 0) & "<>"""")/COUNTIF(" _
    & R.Columns(3).Address(0, 0) & "," & R.Columns(3).Address(0, 0) & "&""""))") - 1
For i = 1 To Unq
    Range("H1").Resize(1, Unq)(i) = "Access" & i
Next i
Range("F1").Resize(1, Unq + 2).EntireColumn.AutoFit
Set R = R.Offset(1, 0).Resize(R.Rows.Count - 1)
V1 = R.Value
V2 = Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row).Value
ReDim Vout(1 To UBound(V2), 1 To Unq)
For i = 1 To UBound(V2, 1)
    For j = 1 To UBound(V1, 1)
        If V1(j, 1) = V2(i, 1) Then
            ct = ct + 1
            Vout(i, ct) = V1(j, 3)
        End If
    Next j
    ct = 0
Next i
Range(Cells(2, "H"), Cells(UBound(V2, 1) + 1, 7 + Unq)).Value = Vout
Application.ScreenUpdating = True
End Sub

 

[Rick Rothstein]

Here is my take on a macro to do what you want (output starts at cell F1)...

[table="width: 500"]
[tr]
	[td]Sub ChangeDataFormat()
  Dim R As Long, Z As Long, LastCol As Long, Data As Variant
  Data = Range("A2", Cells(Rows.Count, "C").End(xlUp))
  Columns("F:K").Clear
  With CreateObject("Scripting.Dictionary")
    For R = 1 To UBound(Data)
      If IsEmpty(.Item(Data(R, 1))) Then .Item(Data(R, 1)) = Data(R, 1) & vbTab & Data(R, 2)
      .Item(Data(R, 1)) = .Item(Data(R, 1)) & vbTab & Data(R, 3)
    Next
    Range("F2").Resize(.Count) = Application.Transpose(.Items)
  End With
  Range("F2").Resize(UBound(Data)).TextToColumns , xlDelimited, , , True, False, False, False, False
  LastCol = Cells.Find("*", , xlValues, , xlByColumns, xlPrevious).Column
  Range("F1:G1") = Array("Name", "ID#")
  Range("H1").Resize(, LastCol - 7) = Evaluate("""Access""&COLUMN(" & Range("A1").Resize(, LastCol - 7).Address & ")")
End Sub[/td]
[/tr]
[/table]

Note: The last three code lines are there strictly to place the headers for the output... if you already have headers pre-placed on row 1 starting at cell F1, then you can delete those last three code lines.

 

[Jamzag]

Thanks All! JoeMo resolved my issue. You guys are wizards!

 

[Rick Rothstein]

Thanks All! JoeMo resolved my issue. You guys are wizards!

Just out of curiosity, how many rows of data to you have?