Excel Pivot Table "Insert Column"

[sirdylan]

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!

 

[pbornemeier]

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.

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]

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]

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:

    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)