макрос, который переворачивает таблицу

[Настя.Пенская]

Здраствуйте.
Помогите, пожалуйста, написать макрос который переворачивает таблицу.
Вот пример:
исходник:
а 1 2 3 4
б 1 2

результат:
1 а б
2 а б
3 а
4 а

Плииз. Очень надо!
Заранее ОГРОМНОЕ спасибо!

[Hugo121]

Массивная =TRANSPOSE(A1:E2) похоже не годится?

Тогда так. Диапазоны в [] можно задать любые.

Option Explicit

Sub tt()
Dim a, b, i As Long, ii As Long

a = [a1:e2]
ReDim b(1 To UBound(a, 2) - 1, 1 To UBound(a, 1) + 1)

For i = 1 To UBound(a)
For ii = 2 To UBound(a, 2)
    If a(i, ii) = ii - 1 Then b(ii - 1, i + 1) = a(i, 1)
Next ii, i

For i = 1 To UBound(b): b(i, 1) = i: Next
[a4].Resize(UBound(b, 1), UBound(b, 2)) = b

End Sub

[vikttur]

Только макрос?

[vikttur]

Файл здесь

[Настя.Пенская]

Сообщение от Hugo121

Массивная =TRANSPOSE(A1:E2) похоже не годится?

Тогда так. Диапазоны в [] можно задать любые.

Option Explicit

Sub tt()
Dim a, b, i As Long, ii As Long

a = [a1:e2]
ReDim b(1 To UBound(a, 2) - 1, 1 To UBound(a, 1) + 1)

For i = 1 To UBound(a)
For ii = 2 To UBound(a, 2)
    If a(i, ii) = ii - 1 Then b(ii - 1, i + 1) = a(i, 1)
Next ii, i

For i = 1 To UBound(b): b(i, 1) = i: Next
[a4].Resize(UBound(b, 1), UBound(b, 2)) = b

End Sub

спасибо за макрос, но он выполняет немного не ту функцию. он переносит номер столбца сверху вниз. а необходимо, чтобы он переносит именно значение. например:

а 5 6 7 1 2
б 3 4
с 1 2 8 7
к 6 1

результат должен выглядеть так:

1 a c к
2 a c
3 б
4 б
5 а
6 а к
7 а с
8 с

в идеале еще группировать данные в одну ячейку через запятую. функция сцепить не подходит, т.к. столбцов будет больше через поддерживает функция.

ЗАРАНЕЕ СПАСИБО.

ОЧЕНЬ НАДЕЮСЬ НА ПОМОЩЬ

[Hugo121]

Не знаю, вроде я всё сделал так, как в первом примере было.
Хотя какой это пример...
Давайте в файле - как есть, как надо.

[Настя.Пенская]

вот пример, спасибо

[Hugo121]

Так тут совсем другой алгоритм нужен, транспонирование тут совсем не годится.
Тут нужно отбирать уникальные в словарь и как итем собирать записи из первого столбца. Ну или в параллельный массив.
Всего данных сколько строк/столбцов?
Но впрочем уже поздно сейчас делать... Завтра...

Настало завтра:

выполните на активном листе с данными

Option Explicit

Sub Nastja()
Dim a, aa(), i&, ii&, j&, u&, s$
a = [a1].CurrentRegion.Value
ReDim aa(1 To UBound(a, 1) * (UBound(a, 2) - 1), 1 To 2)

With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For i = 1 To UBound(a, 1)
    For ii = 2 To UBound(a, 2)
        s = Trim(a(i, ii))
        If Len(s) Then
        If Not .Exists(s) Then
            j = j + 1: .Item(s) = CStr(j)
            aa(j, 1) = s: aa(j, 2) = CStr(a(i, 1))
            Else
            u = .Item(s): aa(u, 2) = aa(u, 2) & ", " & a(i, 1)
        End If
        End If
    Next
    Next
End With

Workbooks.Add.Sheets(1).[a1:b1].Resize(j) = aa

End Sub

На словаре и массиве.
Если [a1].CurrentRegion будет состоять из одного столбца - будет ошибка.

[nilem]

Пока Солнце до Hugo не дошло...
Коллекция.

[Hugo121]

Николай, привет!
Кажется, я когда начинал пост редактировать, ниже ничего не было...
Но не важно, больше решений, хороших и разных!
P.S. Глянул вариант на коллекции - брат-близнец
Мне кажется, первый номер лучше как строку добавлять:
aa(j, 2) = CStr(a(i, 1))
Хотя при выгрузке эксель всё равно в число преобразует, сперва бы формат диапазону задать...