How to group several rows into one column

[granize]

Hi there,

I'll go straight to the point since this is breaking my head and the only way I am seeing to do this is one by one, what would be really time consuming.

Here's my situation:

I have an excel table with 65536 rows and 5 columns. The objective is to have one with 99 columns and around 23000 rows.

The tables is like this:

User Question Answer Code Name
5 1 2 AB xyz
5 2 4 AB xyz
5 3 1 AB xyz
5 4 5 AB xyz
7 1 1 AB xyz
7 2 3 AB xyz
7 3 5 AB xyz
7 4 4 AB xyz

What i need is that the 'User' column is grouped into one row (each user one row) and divided into columns (the questions). Looking like this:

User 1 2 3 4 Code Name
5 2 4 1 5 AB xyz
7 1 3 5 4 AB xyz

I'd appreciate a lot your help, it would save me a lot of time.

Thanks in advance

G.

 

[pboltonchina]

Try this, change sheet name to suit. It will create a sheet a sheet for each question and copy results to that sheet.

Option Explicit

Sub ParseItems()
'Jerry Beaucaire  (11/11/2009)
'Based on selected column, data is filtered to individual sheets
'Creates sheets and sorts sheets alphabetically in workbook
'6/10/2010 - added check to abort if only one value in vCol
Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim WS As Worksheet, MyArr As Variant, vTitles As String, Oops As Boolean

Application.ScreenUpdating = False

'Column to evaluate from, column A = 1, B = 2, etc.
   vCol = 2
 
'Sheet with data in it
   Set WS = Sheets("Sheet1")

'Range where titles are across top of data, as string, data MUST
'have titles in this row, edit to suit your titles locale
    vTitles = "A1:E1"
   
'Spot bottom row of data
   LR = WS.Cells(WS.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from column A
    WS.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter Action:=xlFilterCopy, _
        CopyToRange:=WS.Range("EE1"), Unique:=True

'Sort the temporary list
    WS.Columns("EE:EE").Sort Key1:=WS.Range("EE2"), _
        Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

'Check for more than one value in list
    If WS.Range("EE" & Rows.Count).End(xlUp).Row > 2 Then

'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
        MyArr = Application.WorksheetFunction.Transpose(WS.Range("EE2:EE" _
            & Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
        WS.Range("EE:EE").Clear

    Else
        WS.Range("EE:EE").Clear
        Oops = True
        GoTo ErrorExit
    End If
    
'Turn on the autofilter, one column only is all that is needed
    WS.Range(vTitles).AutoFilter

'Loop through list one value at a time
    For Itm = 1 To UBound(MyArr)
        WS.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm)
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm)
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm)).Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm)).Cells.Clear
        End If

    'customize this section as needed for copy/paste targets
        WS.Range("A" & WS.Range(vTitles).Resize(1, 1).Row & ":A" & LR) _
            .EntireRow.Copy Sheets(MyArr(Itm) & "").Range("A1")

        
        WS.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm)) _
            .Range("A" & Rows.Count).End(xlUp).Row - 1
        Sheets(MyArr(Itm)).Columns.AutoFit
    Next Itm
    
'Cleanup
    WS.AutoFilterMode = False
    MsgBox "Rows with data: " & (LR - 1) & vbLf & "Rows copied to other sheets: " _
                & MyCount & vbLf & "Hope they match!!"

ErrorExit:
    If Oops Then MsgBox "Only one value found, aborting parse process..."
    Application.ScreenUpdating = True
End Sub

 

[granize]

Thanks a lot pboltonchina.

As soon as I get access to the database i will give it a try and will post some feedback.