[Elizavetta]

a_axe,
вот этот код помог

Код:

Sub ResortAttributesGreenGreyRed()

'отключение ненужных функций для ускорения работы макроса
    'Prepare
'Объявление переменных
    Dim ilr, ilColmn, countaa As Long
    Dim CategoriesArr, TempArr As Variant
    Dim wb1, wb2 As String
    wb1 = ActiveWorkbook.Name
'Определение последнего столбца и строки
    ilColmn = Sheets(2).Cells(4, Columns.Count).End(xlToLeft).Column
    countaa = ilColmn / 2
    ReDim CategoriesArr(1 To countaa, 1 To 6)
    For i = 2 To ilColmn Step 2
    CategoriesArr(i / 2, 1) = Sheets(2).Cells(1, i).Interior.Color
    CategoriesArr(i / 2, 2) = Sheets(2).Cells(Rows.Count, i).End(xlUp).Row - 1
    CategoriesArr(i / 2, 6) = Sheets(2).Cells(1, i - 1).Value
    Next i
    
'Окно выбора файла
Application.Dialogs(xlDialogOpen).Show
wb2 = ActiveWorkbook.Name
    ilr = Cells(Rows.Count, 2).End(xlUp).Row
    ilColmn = Cells(1, Columns.Count).End(xlToLeft).Column
'Определение ключевых столбцов
For k = 1 To countaa
For i = 1 To ilColmn
    If Cells(1, i).Interior.Color = CategoriesArr(k, 1) Then
    If CategoriesArr(k, 3) = Empty Then
    CategoriesArr(k, 3) = i
    Else
    If Cells(1, i + 1).Interior.Color <> CategoriesArr(k, 1) Then
    CategoriesArr(k, 4) = i
    End If
    End If
    End If
Next i
CategoriesArr(k, 5) = CategoriesArr(k, 4) - CategoriesArr(k, 3) + 1
Next k
'копируем лист
    Sheets(1).Copy After:=Sheets(1)
    Sheets(2).Select
    Sheets(2).Name = "Result"
'Добавляем результирующие столбцы
For k = countaa To 1 Step -1
    For i = 1 To CategoriesArr(k, 2)
    Columns(CategoriesArr(1, 3)).Select
    Selection.Insert shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Cells(1, CategoriesArr(1, 3)).Value = CategoriesArr(k, 6) & CategoriesArr(k, 2) - i + 1
    Cells(1, CategoriesArr(1, 3)).Interior.Color = CategoriesArr(k, 1)
    Next i
Next k
'определяем сдвиг после добавления стобцов
Dim sdvig As Integer
For Z = 1 To countaa
sdvig = sdvig + CategoriesArr(Z, 2)
Next Z
'корректируем границы исходных категорий после добавления стобцов
For Z = 1 To countaa
CategoriesArr(Z, 3) = CategoriesArr(Z, 3) + sdvig
CategoriesArr(Z, 4) = CategoriesArr(Z, 4) + sdvig
Next Z
Dim tempInt As Integer
'запись в массив и обработка элементов по категориям
    tempInt = CategoriesArr(1, 3) - sdvig
    For i = 2 To countaa * 2 Step 2
        ReDim TempArr(1 To CategoriesArr(i / 2, 2))
        TempArr = Range(Workbooks(wb1).Sheets(2).Cells(2, i), Workbooks(wb1).Sheets(2).Cells(CategoriesArr(i / 2, 2) + 1, i))
        For k = CategoriesArr(i / 2, 3) To CategoriesArr(i / 2, 4)
            For Z = 2 To ilr
                For T = 1 To CategoriesArr(i / 2, 2)
                If InStr(1, Cells(Z, k).Value, TempArr(T, 1)) > 0 Then
                Cells(Z, tempInt - 1 + T).Value = Cells(Z, k).Value
                End If
                Next T
            Next Z
        Next k
        tempInt = tempInt + CategoriesArr(i / 2, 2)
    Next i
    
    'Удаляем исходные столбцы

    Range(Columns(CategoriesArr(1, 3)), Columns(CategoriesArr(countaa, 4))).Delete

   
    

Ended
End Sub

Public Sub Prepare()
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.DisplayStatusBar = False
    Application.DisplayAlerts = False
End Sub

Public Sub Ended()
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    ActiveSheet.DisplayPageBreaks = True
    Application.DisplayStatusBar = True
    Application.DisplayAlerts = True
End Sub