Pivot table/transposing columns

[cooter_slackjaw]

Hi,

I need to transpose some data from columns to rows, it is not easy to explain in words what I want do so I have put an example below and see attached file:

The data is currently in the following format(two headers are col. A = Site and col. B = Cell ID):


SITE - Cell ID
312P0011A - 50112
312P0011A - 50151
312P0011A - 50052
312P0011A - 50153
312P0011A - 51881
312P0011A - 50152
312P0052A - 10411
312P0052A - 51881
312P0052A - 51673
312P0052A - 51672
312P0122A - 50052
312P0122A - 51803
312P0122A - 51223
312P0122A - 51222

The output I want is as follows:

SITE Cell ID
312P0011A 50112 50151 50052 50153 51881 50152
312P0052A 10411 51881 51673 51672
312P0122A 50052 51803 51223 51222

So basically I have compiled a row for each of the entries in column A (Sites).

I need to do this on a lot of data and wondered if there is a quick way of doing this, it seems to be a mix of transposing the data and pivot table, but no matter what I try I can't get the right results.

Any help would be greatly appreciated.
Thanks!

[AlfD]

Hi!

This is not the most elegant of solutions (VBA would probably be).

Select the table and create a pivot table with SITE and CellID as row headings and Count of CellID as the Value.
This generates a table like this:

312P0011A 	6
50052	1
50112	1
50151	1
50152	1
50153	1
51881	1
312P0052A 	4
10411	1
51672	1
51673	1
51881	1
312P0122A 	4
50052	1
51222	1
51223	1
51803	1
Grand Total	14

The first column of this pivot table really has what you are looking for, but not in quite the right format.
Make a copy of this first column and put it (pastespecial/format followed by pastespecial/values) somewhere convenient such as another worksheet.
You can now extract each subgroup of data (manually, I'm afraid) with its Site and associated Cell IDs. Copy each such set and pastespecial/transpose somewhere suitable.

Clunky, but it works.

Alf

[stephenkraj]

Hi Cooter,

Please try this below code..

Sub form()
    
Dim FixRow, FixCol As Integer
Dim Sign As Boolean
 
 FixRow = 2
 LstCell = Cells(Rows.Count, 2).End(xlUp).Row
    
    While FixRow <= LstCell
      
      If Sign = False And Cells(FixRow, 1) = Cells(FixRow + 1, 1) Then
        FixCol = Cells(FixRow, Columns.Count).End(xlToLeft).Column
        Sign = True
      End If
      
      If Cells(FixRow, 1) = Cells(FixRow + 1, 1) Then
        Cells(FixRow, FixCol + 1) = Cells(FixRow + 1, 2)
        FixCol = Cells(FixRow, Columns.Count).End(xlToLeft).Column
        Cells(FixRow + 1, 2).EntireRow.Delete
      End If
            
      If Cells(FixRow, 1) <> Cells(FixRow + 1, 1) Then
         Sign = False
         FixRow = FixRow + 1
      End If
      LstCell = Cells(Rows.Count, 2).End(xlUp).Row
      
   Wend
   
End Sub