[okshef]

В каких строчках вашего файла ошибки? Вам не кажется, что некоторые данные просто сдвинуты?

[Elizavetta]

okshef, здравствуйте! Нет они не сдвинуты. Немного поясню. Для фирм есть три категории опасности\
RED
GREEN
GREY
Каждая категория представляет собой ряд показателей. Для GREEN их от 8-10 может быть.(чистая прибыль, дела о банкротстве...)
Проблема в том, что для фирм они заполнялись в разных порядках

Фирма 1: 1,4,5,6,8,2,3,4(это номера показателей)
Фирма 2: 4,6,1,5,8,3
...
И так далее

Задача перестроить эти показатели по порядку для каждой фирмы. Но с сохранением структуры наблюдений по другим показателям(помимо RED,GREY,GREEN есть другие колонки).

Если я непонятно объяснила, Вы можете мне задавать уточняющие вопросы.

[okshef]

Elizavetta, чтобы выполнить задачу, нужно знать ВСЕ возможные критерии соотнесения событий к категориям и подкатегориям. Вот ваш текст

Каждая категория имеет подкатегории например для green "Чистая прибыль" 1 458 тыс. руб "Размер непогашенного обязательства не превышает "300 000 руб "Нет в реестре массовых руководителей" "Чистая прибыль" 1 814 тыс. руб »

Категорий GREEN у вас 10. Что к чему должно соотносится? И это только 4 строчки...

[Elizavetta]

okshef, я Вас поняла
Green

Нет дел о банкротстве
Размер непогашенного платежа
Выручка
Нет в реестре массовых руководителей
Нет дисквалифицированных лиц
Выиграны госконтракты
Размещены госконтракты
Нет в реестре недобросовестных поставщиков

Red

Чистый убыток
Внеплановые проверки
Нарушение по проверкам


Grey
Ответчик
Истец
Задолженность по исп.производствам
Плановые проверки
В реестре операторов персональных данных
Нет в реестре малого и среднего бизнеса



пример
https://gyazo.com/eae544e864ac5ddbc407b90f18ddff77

[a_axe]

Но проблема в том, что они идут неструктурировано наппример для одной компании "Чистая прибыль" в столбце green1, а для другой в green2. »

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

Можно ли каждую такую категорию встроить в отдельный столбец и переписать туда значения, но чтобы согласовались наблюдения »

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

Например: ищем в строчке номер 1 фразу "Выручка" плюс некий текст после, если фраза в этой строчке есть - записываем найденное значение ячейки в этот столбец.

Если задача такая, то решается она следующим образом (для вашего выложеного примера): в ячейку AT1 вбейте фразу "Выручка" без кавычек.
В ячейку AT3 вбейте формулу =ЕСЛИОШИБКА(ИНДЕКС(A3:AS3;1;ПОИСКПОЗ($AT$1 & "*";A3:AS3;0));"") и протяните ее ниже.
Если фразы в данной строчки нет, ячейка будет пустой, если фраза в данной строчке есть - в столбец AT будет вписано значение ячейки текущей строки, начинающейся с этого текста, включая и последующий текст, т.е. "Выручка 114 572 тыс. руб" и т.п.
Для каждой фразы делаете аналогичный столбец, и так в нужном вам порядке.

[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