Переупорядочить определенные столбцы и строки

С Excel 2007 вам не обязательно нужен VBA. В мастере сводных таблиц (Alt+D, P) выберите «Несколько диапазонов консолидации», «Далее» выберите «Я создам поля страницы», «Далее» выберите свои данные, «Далее» выберите «Новый рабочий лист», «Готово». Дважды щелкните нижнюю правую ячейку сводной таблицы. Отфильтруйте по столбцу A и удалите пустые строки, отфильтруйте по столбцу B и удалите строки, содержащие «Тип». Вставьте столбцы справа от «Строка» и «Столбец» и заполните значениями поиска.

Если вам не совсем удобно использовать ПРОСМОТР и у вас есть управляемое количество диапазонов, есть альтернатива, которая немного более утомительна, но может быть легче запомнить, если такая «перестановка» потребуется снова, и вы забыли, как именно!

1. Клонируйте столько копий электронной таблицы данных, сколько у вас есть диапазонов (сохраните «оригинал» [скажем, Sheet1] в качестве резервной копии).
2. Вставьте столбцы B и C в каждую копию (не в Sheet1).
3. На Листе2 скопируйте E1 и E2 в C3 и D3.
4. На листе Sheet3 скопируйте F1 и F2 в C3 и D3.
5. На листе Sheet4 скопируйте G1 и G2 в C3 и D3.
6. Повторите процесс с 3. по 5. при необходимости.
7. В Sheet2 удалите столбцы F и G.
8. В Sheet3 удалите столбцы E и G.
9. В Sheet4 удалите столбцы E и F.
10. Повторите процесс с 7. по 9. при необходимости.
11. В столбцах C и D добавьте букву, например «z», к номерам диапазонов и значениям на каждом из листов со 2 по 4.
12. Выберите C3 и D3 на листе 2 и дважды щелкните в правом нижнем углу.
13. Повторите 12. для всех остальных листов (кроме Sheet1).
14. Удалите столбцы F и G из Sheet2.
15. Удалите столбцы E и G из Sheet3.
16. Удалите столбцы E и F из Sheet4.
17. Повторите процесс с 14. по 16. при необходимости.
18. Отфильтруйте ColumnC в Sheet3 для r2z и скопируйте видимый в нижнюю часть Sheet2.
19. Отфильтруйте столбец C на листе 4 для r3z и скопируйте видимый в нижнюю часть листа2.
20. Повторите процесс 18. и 19. при необходимости.
21. В Sheet2 замените «z» ничем.

Вы можете сделать это с помощью PasteSpecial, как показано ниже.

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

Нельзя ли просто скопировать и вставить специально и выбрать транспонирование?

На самом деле, снова взглянув на ОП, это не прямое транспонирование, поскольку первые два столбца на вашем втором снимке экрана не являются прямым транспонированием.

ПОСЛЕДНИЕ РЕДАКТИРОВАНИЯ

Ок - вроде работает...

 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