Перенос столбцов в строки с приминением фильтров

Страница 1 из 1 1
Модератор форума: китин, _Boroda_, DrMini

Перенос столбцов в строки с приминением фильтров (Формулы/Formulas)

Alex_Mag

Дата: Вторник, 20.03.2018, 23:14 | Сообщение № 1

Группа: Пользователи

Ранг: Прохожий

Сообщений: 6

Репутация: 0 ±

Замечаний: 0% ±

Excel 2016

Здравствуйте.
Прошу помочь с решением задачи, условия следующие:

Есть 5 столбов с разными заголовками (Китай, Франция, Германия, Россия, Америка) и в каждом столбе есть повторяющиеся значения (страны).
Необходимо перенести их в строки таким образом, что если в столбцах есть к примеру Агадир то в его столбце появляется те заголовки в чьих столбцах есть это значение

Файл во вложении.

К сообщению приложен файл: Workbook2.xls (68.0 Kb)

Ответить

sboy

Дата: Среда, 21.03.2018, 10:18 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 2566

Репутация: 724 ±

Замечаний: 0% ±

Excel 2010

Добрый день.
[vba]

Код

Sub Alex_Mag()
Application.ScreenUpdating = False
    For c = 1 To 5
        Range(Cells(c), Cells(c).End(xlDown)).RemoveDuplicates 1, xlYes
    Next
    arr = Cells(1).CurrentRegion.Value
    q = UBound(arr)
        Set d = CreateObject("Scripting.Dictionary")
            For i = 1 To UBound(Application.Transpose(arr))
                For j = 2 To UBound(arr)
                    If Not IsEmpty(arr(j, i)) Then
                        If d.exists(arr(j, i)) Then
                            d.Item(arr(j, i)) = d.Item(arr(j, i)) & "|" & arr(1, i)
                            Else: d.Add arr(j, i), arr(1, i)
                        End If
                    End If
                Next
            Next
            keysarr = d.keys
            Set r = Cells(2, 8).Resize(1, UBound(keysarr) + 1)
            r.Value = keysarr
                For Each cl In r.Cells
                    itemarr = Split(d.Item(cl.Value), "|")
                    cl.Offset(1, 0).Resize(UBound(itemarr) + 1, 1).Value = Application.Transpose(itemarr)
                Next
            Set d = Nothing
Application.ScreenUpdating = True
End Sub

[/vba]
[p.s.]Начал изучать "словарик", критика приветствуется