Rearrange certain columns and rows

Question

I have an Excel spreadsheet formatted like this:

What I have been trying to do is format it to look like this:

So it's kind of transposed I guess (not sure how to call it).

I've spent the last hour and a half trying to do it in VBA with no success.

This is just a sample of how it is formatted, in reality there's about 50,000 of these, so I need to do it using VBA or something of the sort.

Would someone be able to help me out with how to do this?

Answer 1

With Excel 2007 you don’t necessarily need VBA. In Pivot Table Wizard (Alt+D, P) select ‘Multiple consolidation ranges’, Next, select ‘I will create the page fields’, Next, select your data, Next, select ‘New worksheet’, Finish. Double click on bottom RH cell of pivot table. Filter on ColumnA and delete blank rows, filter on ColumnB and delete rows containing “Type". Insert columns to the right of “Row” and “Column” and fill with lookup values.

Answer 2

If you are not fully comfortable with LOOKUP and have a manageable number of ranges there is an alternative that is a bit more tedious but might be easier to remember if such ‘transposition’ is required again and you have forgotten exactly how!

1. Clone as many copies of the data spreadsheet as you have ranges (keep ‘original’ [say Sheet1] as backup).
2. Insert Columns B and C into each copy (not Sheet1).
3. In Sheet2, copy E1 and E2 to C3 and D3.
4. In Sheet3, copy F1 and F2 to C3 and D3.
5. In Sheet4, copy G1 and G2 to C3 and D3.
6. Repeat process 3. to 5. as necessary.
7. In Sheet2 delete Columns F and G.
8. In Sheet3 delete Columns E and G.
9. In Sheet4 delete Columns E and F.
10. Repeat process 7. to 9. as necessary.
11. In Columns C and D append a letter, say ‘z’, to the range numbers and values in each of Sheets2 to 4.
12. Select C3 and D3 in Sheet 2 and double-click on bottom RH corner.
13. Repeat 12. for all other sheets (except Sheet1).
14. Delete Columns F and G from Sheet2.
15. Delete Columns E and G from Sheet3.
16. Delete Columns E and F from Sheet4.
17. Repeat process 14. to 16. as necessary.
18. Filter ColumnC in Sheet3 for r2z and copy visible to bottom of Sheet2.
19. Filter ColumnC in Sheet 4 for r3z and copy visible to bottom of Sheet2.
20. Repeat process 18. and 19. as necessary.
21. In Sheet2 replace ‘z’ by nothing.

Answer 3

Can you not just copy and pastespecial and select transpose?

Actually looking again at the OP this is not a straight transpose as the first two columns in your second screenprint are not a straight transpose.

FINAL EDIT

Ok - seems to work ...

 Option Base 1

Sub moveData()

    Dim NumIterations As Integer
    NumIterations = ThisWorkbook.Sheets("target").Cells(Rows.Count, 3).End(xlUp).Row - 2

    'get the raw data and add to an array
    Dim n As Long
    Dim m As Long
    Dim myArray() As Long
    ReDim myArray(1 To NumIterations, 1 To 3)
    For n = 1 To NumIterations
        For m = 1 To 3
            myArray(n, m) = ThisWorkbook.Sheets("target").Cells(n + 2, m + 2)
        Next m
    Next n

    Dim q As Long
    Dim r As Long
    Dim myStaticArray()
    ReDim myStaticArray(1 To NumIterations, 1 To 2)
    For q = 1 To NumIterations
        For r = 1 To 2
            myStaticArray(q, r) = ThisWorkbook.Sheets("target").Cells(q + 2, r)
        Next r
    Next q


     'spit the data back out
    Dim i As Long
    Dim j As Long
    Dim myRow As Long
    myRow = 0

    For i = 1 To NumIterations
        For j = 1 To 3

            myRow = myRow + 1

            ThisWorkbook.Sheets("answer").Cells(myRow, 1) = myStaticArray(i, 1)
            ThisWorkbook.Sheets("answer").Cells(myRow, 2) = myStaticArray(i, 2)

            If j = 1 Then
                ThisWorkbook.Sheets("answer").Cells(myRow, 3) = "r1"
                ThisWorkbook.Sheets("answer").Cells(myRow, 4) = "11-000 - 13-000"
            ElseIf j = 2 Then
                ThisWorkbook.Sheets("answer").Cells(myRow, 3) = "r2"
                ThisWorkbook.Sheets("answer").Cells(myRow, 4) = "15-000 - 30-000"
            ElseIf j = 3 Then
                ThisWorkbook.Sheets("answer").Cells(myRow, 3) = "r3"
                ThisWorkbook.Sheets("answer").Cells(myRow, 4) = "31-000"
            End If

            ThisWorkbook.Sheets("answer").Cells(myRow, 5) = myArray(i, j)

        Next j
    Next i

End Sub

Answer 4

You can do it using PasteSpecial as shown below

Sheet(1).UsedRange.Select
Selection.Copy
ActiveWorkbook.Sheets.Add   'Make some room for pasting the cells in the new format 
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Application.CutCopyMode = False