Excel Pivot Table "Insert Column"

sirdylan

New Member
Joined
Oct 9, 2019
Messages
2
Hello,


I have the results of a survey in an Excel spreadsheet, like this:

Question

<tbody>
</tbody>
Grade

<tbody>
</tbody>
StrVal

<tbody>
</tbody>
Flowers and Decoration Team

<tbody>
</tbody>
-1

<tbody>
</tbody>
N/A

<tbody>
</tbody>
******* and Fellowship Team

<tbody>
</tbody>
5

<tbody>
</tbody>
Excellent

<tbody>
</tbody>

<tbody>
</tbody>



and i need to rearrange like this:

Flowers and Decoration Team

<tbody>
</tbody>
Comments

<tbody>
</tbody>
******* and Fellowship Team

<tbody>
</tbody>
Comments2

<tbody>
</tbody>
-1

<tbody>
</tbody>
N/A

<tbody>
</tbody>
5

<tbody>
</tbody>
Excellent

<tbody>
</tbody>



I need to automate this process with macros, i was thinking using pivot table but i can't figure out how to bring Comments Column after every question.Any suggestion?




Thanks!
 

Some videos you may like

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,775
Start this code on the (one) sheet containing data.
The code will have to be tweaked if you have multiple sheets to process.
If this is the case, please provide information about those sheets.

Code:
Sub RearrangeData()

    Dim lLastRow As Long
    Dim lRowIndex As Long
    Dim lColIndex As Long
    Dim lWriteRow As Long
    Dim sWorksheet As String
    Dim sDataSheet As String
    
    sDataSheet = ActiveSheet.Name
    
    'Create new sheet to hold changed data
    sWorksheet = "New Data"
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets(sWorksheet).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    Worksheets.Add(After:=Sheets(Sheets.Count)).Name = sWorksheet 'After last
    
    With Worksheets(sWorksheet)
        lWriteRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    End With
    
    With Worksheets(sDataSheet)
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For lRowIndex = 2 To lLastRow
            lColIndex = 1 + (3 * (lRowIndex - 2))
            Range(.Cells(lRowIndex, 1), .Cells(lRowIndex, 3)).Copy _
                Destination:=Worksheets(sWorksheet).Cells(lWriteRow, lColIndex)
        Next
        
    End With
    With Worksheets(sWorksheet)
        .UsedRange.ColumnWidth = 50
        .UsedRange.Columns.AutoFit
        .UsedRange.Rows.AutoFit
    End With
End Sub
 

sirdylan

New Member
Joined
Oct 9, 2019
Messages
2
Thanks for reply, it's helped me a lot, but i can t figure out how to skip Grade Column --> here ->

With Worksheets(sDataSheet) lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For lRowIndex = 2 To lLastRow
lColIndex = 1 + (3 * (lRowIndex - 2))
Range(.Cells(lRowIndex, 1), .Cells(lRowIndex, 3)).Copy _
Destination:=Worksheets(sWorksheet).Cells(lWriteRow, lColIndex)
 

pbornemeier

Well-known Member
Joined
May 24, 2005
Messages
3,775
The grade column header did not appear in your desired output, but the values did so I included them. If you only want to extract the questions and comments replace the lines in post #3 with:

Code:
    With Worksheets(sDataSheet)
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        For lRowIndex = 2 To lLastRow
            lColIndex = 1 + (2 * (lRowIndex - 2))
            .Cells(lRowIndex, 1).Copy _
                Destination:=Worksheets(sWorksheet).Cells(lWriteRow, lColIndex)
            .Cells(lRowIndex, 3).Copy _
                Destination:=Worksheets(sWorksheet).Cells(lWriteRow, lColIndex + 1)
 

Watch MrExcel Video

Forum statistics

Threads
1,089,921
Messages
5,411,246
Members
403,353
Latest member
ecboy1605

This Week's Hot Topics

Top