Sub CopyOneParentPerChildToNewSheet()
    ' Объявление переменных
    Dim wsSrc As Worksheet     ' Исходный лист с данными
    Dim wsDest As Worksheet    ' Целевой лист для результатов
    Dim lastRow As Long        ' Последняя заполненная строка в исходном листе
    Dim destRow As Long        ' Текущая строка для записи на целевом листе
    Dim priorities As Object   ' Словарь для определения приоритетов ролей
    Dim dict As Object         ' Словарь для хранения выбранных строк по каждому ребенку
    Dim i As Long              ' Переменная для циклов
    Dim childKey As Variant    ' Уникальный ключ для ребенка (ФИО в нижнем регистре)
    Dim role As String         ' Роль родителя
    Dim parentFIO As String    ' ФИО родителя
    Dim priority As Long       ' Приоритет текущей роли
    Dim currentItem As Variant ' Массив, содержащий приоритет и индекс строки для выбранного родителя
    Dim nameParts() As String  ' Массив для разделения ФИО ребенка из столбца A
    Dim roleParts() As String  ' Массив для разделения роли и ФИО родителя из столбца B
    
    ' Переменные для обработки сценария, где ФИО ребенка не повторяется в каждой строке родителя
    Dim lastKnownChildFIO As String
    Dim lastKnownChildKey As String
    Dim lastKnownChildDate As Variant ' To store the child's date
    
    ' Устанавливаем исходный лист (поменяйте "Лист1" на актуальное имя вашего листа)
    Set wsSrc = ThisWorkbook.Sheets("Лист1")
    
    ' Создаем новый лист "Результат", если он не существует, или очищаем его, если он уже есть
    On Error Resume Next
    Set wsDest = ThisWorkbook.Sheets("Результат")
    On Error GoTo 0
    
    If wsDest Is Nothing Then
        Set wsDest = ThisWorkbook.Sheets.Add(After:=wsSrc)
        wsDest.Name = "Результат"
    Else
        wsDest.Cells.ClearContents ' Очищаем только содержимое, сохраняя форматирование
    End If
    
    ' Определяем новые заголовки для целевого листа
    wsDest.Cells(1, 1).Value = "Фамилия Ребенка"
    wsDest.Cells(1, 2).Value = "Имя Ребенка"
    wsDest.Cells(1, 3).Value = "Отчество Ребенка"
    wsDest.Cells(1, 4).Value = "Дата Ребенка"   ' Теперь на 4-й позиции
    wsDest.Cells(1, 5).Value = "Роль"           ' Теперь на 5-й позиции
    wsDest.Cells(1, 6).Value = "ФИО Родителя"   ' Теперь на 6-й позиции
    wsDest.Cells(1, 7).Value = "Дата Родителя"  ' Теперь на 7-й позиции
    
    ' Находим последнюю заполненную строку в столбце A исходного листа
    lastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).Row
    
    ' Инициализируем словарь приоритетов ролей (чем меньше число, тем выше приоритет)
    Set priorities = CreateObject("Scripting.Dictionary")
    priorities.Add "мать", 1
    priorities.Add "отец", 2
    priorities.Add "отчим", 3
    priorities.Add "бабушка", 4
    priorities.Add "дедушка", 5
    
    ' Инициализируем словарь для хранения лучшей строки для каждого ребенка
    ' Формат: childKey -> Array(priority, sourceRowIndex)
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Этап 1: Проходим по всем строкам исходного листа, чтобы найти родителя с наивысшим приоритетом для каждого ребенка
    For i = 2 To lastRow ' Начинаем со второй строки, пропуская заголовки
        Dim rawChildNameColA As String      ' Данные из столбца A (ФИО ребенка + доп. инфо)
        Dim rawRoleAndParentColB As String  ' Данные из столбца B (роль + ФИО родителя)
        Dim currentChildFIO As String       ' Извлеченное ФИО ребенка (полное)
        Dim currentRole As String           ' Извлеченная роль
        Dim currentParentFIO As String      ' Извлеченное ФИО родителя
        Dim currentPriority As Long         ' Приоритет текущей записи
        Dim currentChildDate As Variant     ' Дата ребенка для текущей строки
        
        rawChildNameColA = Trim(wsSrc.Cells(i, "A").Value)
        
        ' --- ЛОГИКА ДЛЯ ОПРЕДЕЛЕНИЯ ТЕКУЩЕГО РЕБЕНКА ---
        ' Если столбец A для текущей строки не пуст, это новая запись ребенка
        If rawChildNameColA <> "" Then
            If InStr(rawChildNameColA, ",") > 0 Then
                nameParts = Split(rawChildNameColA, ",")
                currentChildFIO = Trim(nameParts(0))
            Else
                currentChildFIO = rawChildNameColA
            End If
            childKey = LCase(currentChildFIO)
            
            ' Дата ребенка берется из столбца C этой же строки
            currentChildDate = wsSrc.Cells(i, "C").Value
            
            ' Обновляем "последнего известного" ребенка
            lastKnownChildFIO = currentChildFIO
            lastKnownChildKey = childKey
            lastKnownChildDate = currentChildDate
        Else
            ' Если столбец A пуст, используем данные о последнем известном ребенке
            currentChildFIO = lastKnownChildFIO
            childKey = lastKnownChildKey
            currentChildDate = lastKnownChildDate
            
            ' Если lastKnownChildKey пуст, значит, первая строка данных пуста в A, что является ошибкой или неверным форматом.
            If childKey = "" Then
                ' Возможно, стоит добавить MsgBox или Error Handling здесь
                GoTo NextRow ' Пропускаем эту строку, так как нет информации о ребенке
            End If
        End If
        ' --- КОНЕЦ ЛОГИКИ ДЛЯ ОПРЕДЕЛЕНИЯ ТЕКУЩЕГО РЕБЕНКА ---
        
        rawRoleAndParentColB = Trim(wsSrc.Cells(i, "B").Value)
        
        ' --- НОРМАЛИЗАЦИЯ РАЗДЕЛИТЕЛЯ ДАТЫ/ФИО РОДИТЕЛЯ (ОБРАБАТЫВАЕМ РАЗНЫЕ ТИРЕ) ---
        rawRoleAndParentColB = Replace(rawRoleAndParentColB, "–", "-") ' Заменяем en-dash на hyphen
        rawRoleAndParentColB = Replace(rawRoleAndParentColB, "—", "-") ' Заменяем em-dash на hyphen
        ' --- КОНЕЦ НОРМАЛИЗАЦИИ ---
        
        ' Разделяем роль и ФИО родителя из столбца B
        If InStr(rawRoleAndParentColB, "-") > 0 Then
            roleParts = Split(rawRoleAndParentColB, "-")
            currentRole = LCase(Trim(roleParts(0)))    ' Роль до дефиса
            currentParentFIO = Trim(roleParts(1))       ' ФИО родителя после дефиса
        Else
            currentRole = LCase(rawRoleAndParentColB)   ' Если дефиса нет, вся строка - роль
            currentParentFIO = ""                       ' ФИО родителя не указано
        End If
        
        ' Определяем приоритет для текущей роли
        If priorities.Exists(currentRole) Then
            currentPriority = priorities(currentRole)
        Else
            currentPriority = 99 ' Очень низкий приоритет для неизвестных ролей
        End If
        
        ' Обновляем словарь, если найдена запись с более высоким приоритетом (меньшим числом)
        ' Теперь dict хранит: Array(priority, sourceRowIndex, childFIO, childDate)
        If dict.Exists(childKey) Then
            currentItem = dict(childKey) ' Получаем текущий лучший элемент для этого ребенка
            If currentPriority < currentItem(0) Then ' Сравниваем приоритеты
                ' Обновляем: приоритет, индекс исходной строки, ФИО ребенка, дата ребенка
                dict(childKey) = Array(currentPriority, i, currentChildFIO, currentChildDate)
            End If
        Else
            ' Добавляем нового ребенка в словарь: приоритет, индекс исходной строки, ФИО ребенка, дата ребенка
            dict.Add childKey, Array(currentPriority, i, currentChildFIO, currentChildDate)
        End If
NextRow:
    Next i
    
    ' Этап 2: Копируем выбранные строки на новый лист и извлекаем/разделяем данные
    destRow = 2 ' Начинаем запись со второй строки на целевом листе (после заголовков)
    For Each childKey In dict.Keys ' Проходим по каждому ребенку в словаре
        currentItem = dict(childKey)
        Dim sourceRowIndex As Long
        sourceRowIndex = currentItem(1) ' Получаем индекс строки из исходного листа
        
        ' Извлекаем данные о ребенке, которые были сохранены в словаре
        Dim childFIOToOutput As String
        Dim childDateToOutput As Variant
        childFIOToOutput = currentItem(2)
        childDateToOutput = currentItem(3)
        
        ' Извлекаем роль и ФИО родителя из исходного листа для выбранной строки
        Dim tempRoleParentRaw As String
        tempRoleParentRaw = Trim(wsSrc.Cells(sourceRowIndex, "B").Value)
        tempRoleParentRaw = Replace(tempRoleParentRaw, "–", "-") ' Нормализация тире
        tempRoleParentRaw = Replace(tempRoleParentRaw, "—", "-") ' Нормализация тире
        
        Dim roleToOutput As String
        Dim parentFIOToOutput As String
        If InStr(tempRoleParentRaw, "-") > 0 Then
            roleParts = Split(tempRoleParentRaw, "-")
            roleToOutput = Trim(roleParts(0))
            parentFIOToOutput = Trim(roleParts(1))
        Else
            roleToOutput = tempRoleParentRaw
            parentFIOToOutput = ""
        End If
        
        ' Получаем дату родителя из столбца D исходного листа для выбранной строки
        Dim parentDateToOutput As Variant
        parentDateToOutput = wsSrc.Cells(sourceRowIndex, "D").Value
        
        ' Разделяем ФИО ребенка на Фамилию, Имя, Отчество
        Dim childFIONameParts As Variant ' Для разделения ФИО ребенка на части
        Dim childLastName As String
        Dim childFirstName As String
        Dim childMiddleName As String
        
        childLastName = ""
        childFirstName = ""
        childMiddleName = ""

        If childFIOToOutput <> "" Then
            childFIONameParts = Split(childFIOToOutput, " ")
            
            If UBound(childFIONameParts) >= 0 Then childLastName = childFIONameParts(0)
            If UBound(childFIONameParts) >= 1 Then childFirstName = childFIONameParts(1)
            
            ' Собираем Отчество из оставшихся частей (если их больше двух)
            If UBound(childFIONameParts) >= 2 Then
                Dim k As Long
                Dim tempMiddleName As String
                tempMiddleName = ""
                For k = 2 To UBound(childFIONameParts)
                    If k = 2 Then
                        tempMiddleName = childFIONameParts(k)
                    Else
                        tempMiddleName = tempMiddleName & " " & childFIONameParts(k)
                    End If
                Next k
                childMiddleName = tempMiddleName
            End If
        End If
        
        ' Записываем извлеченные и разделенные данные на целевой лист
        wsDest.Cells(destRow, 1).Value = childLastName
        wsDest.Cells(destRow, 2).Value = childFirstName
        wsDest.Cells(destRow, 3).Value = childMiddleName
        wsDest.Cells(destRow, 4).Value = childDateToOutput   ' Дата Ребенка после ФИО
        wsDest.Cells(destRow, 5).Value = roleToOutput
        wsDest.Cells(destRow, 6).Value = parentFIOToOutput
        wsDest.Cells(destRow, 7).Value = parentDateToOutput
        
        ' Копируем все остальные столбцы (начиная со столбца E исходного листа)
        ' Теперь они будут вставлены начиная со столбца 8 на целевом листе
        Dim lastColSrc As Long
        ' Находим последнюю заполненную колонку в исходной строке, чтобы скопировать все данные
        lastColSrc = wsSrc.Cells(sourceRowIndex, wsSrc.Columns.Count).End(xlToLeft).Column
        
        If lastColSrc >= 5 Then ' Если есть столбцы начиная с E в источнике (исходная колонка 5)
            ' Копируем диапазон от столбца E до последней заполненной колонки из источника
            ' Вставляем на целевой лист, начиная со столбца 8
            wsSrc.Range(wsSrc.Cells(sourceRowIndex, 5), wsSrc.Cells(sourceRowIndex, lastColSrc)).Copy _
                Destination:=wsDest.Cells(destRow, 8)
            
            ' Копируем заголовки для этих дополнительных столбцов, если это первая строка данных (для новой структуры)
            If destRow = 2 Then
                Dim j As Long
                For j = 5 To lastColSrc
                    ' Заголовки исходных столбцов E, F, G... будут помещены в столбцы 8, 9, 10... соответственно
                    wsDest.Cells(1, j + 3).Value = wsSrc.Cells(1, j).Value
                Next j
            End If
        End If
        
        destRow = destRow + 1 ' Переходим к следующей строке на целевом листе
    Next childKey
    
    ' Автоматическая подгонка ширины столбцов для лучшей читаемости
    wsDest.Columns.AutoFit
    
    ' Сообщение об успешном завершении
    MsgBox "Готово! Результат скопирован на лист 'Результат'."
    
End Sub

Ошибка syntax error на строке nameParts = split(rawchildNameColA...