Sub ProcessChildParentDataFlexible()
    ' Объявление переменных
    Dim wsOriginal As Worksheet
    Dim wsNew As Worksheet
    Dim lastRowOriginal As Long
    Dim i As Long
    Dim newRow As Long
    Dim childName As String
    Dim childDOB As String
    Dim currentParentInfoRow As Long ' Для отслеживания текущей строки с информацией о родителе
    Dim parentInfo As String
    Dim parentName As String
    Dim parentDOB As String
    Dim relation As String
    Dim parentsCollection As Collection ' Коллекция для хранения информации о родителях
    Dim parentDetail As Variant
    Dim foundParent As Boolean
    Dim tempParentDOB As String
    Dim potentialChildRow As Long
    Dim j As Long ' Объявление переменной j здесь

    ' Установка листа с исходными данными (предполагается, что данные на первом листе)
    Set wsOriginal = ThisWorkbook.Sheets(1) ' Можете изменить на имя вашего листа, например: ThisWorkbook.Sheets("Лист1")

    ' Создание нового листа для обработанных данных
    On Error Resume Next ' Игнорировать ошибку, если лист уже существует
    Application.DisplayAlerts = False ' Отключить предупреждения
    ThisWorkbook.Sheets("Обработанные Данные").Delete ' Удалить, если уже существует
    Application.DisplayAlerts = True ' Включить предупреждения обратно
    On Error GoTo 0 ' Сбросить обработчик ошибок

    Set wsNew = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsNew.Name = "Обработанные Данные"

    ' Добавление заголовков в новый лист
    wsNew.Cells(1, 1).Value = "ФИО Ребенка"
    wsNew.Cells(1, 2).Value = "Дата Рождения Ребенка"
    wsNew.Cells(1, 3).Value = "Родство"
    wsNew.Cells(1, 4).Value = "ФИО Родителя"
    wsNew.Cells(1, 5).Value = "Дата Рождения Родителя"
    newRow = 2 ' Начинаем запись данных со второй строки

    ' Находим последнюю заполненную строку на исходном листе в столбце A
    lastRowOriginal = wsOriginal.Cells(wsOriginal.Rows.Count, "A").End(xlUp).Row

    i = 1 ' Начинаем сканирование с первой строки

    ' Основной цикл для прохода по всем данным
    Do While i <= lastRowOriginal
        childName = ""
        childDOB = ""
        Set parentsCollection = New Collection

        ' 1. Находим ФИО ребенка
        ' Ищем ячейку в столбце A, которая не пуста и не является датой (предполагаем, что это ФИО)
        Do While i <= lastRowOriginal And (IsEmpty(wsOriginal.Cells(i, 1).Value) Or IsDate(wsOriginal.Cells(i, 1).Value))
            i = i + 1 ' Пропускаем пустые или датированные ячейки в A, пока не найдем имя
        Loop

        If i > lastRowOriginal Then Exit Do ' Если дошли до конца листа, выходим

        ' Предполагаем, что нашли ФИО ребенка
        Dim currentCellVal As String
        currentCellVal = Trim(wsOriginal.Cells(i, 1).Value)

        ' Пробуем разделить ФИО ребенка и дату рождения, если дата в той же ячейке
        Dim parts As Variant
        parts = Split(currentCellVal, " ")

        If UBound(parts) >= 0 Then ' Проверяем, что массив не пуст
            Dim lastPart As String
            lastPart = parts(UBound(parts))
            ' Проверяем, похоже ли на дату
            If IsDate(lastPart) Then
                childDOB = Format(CDate(lastPart), "DD.MM.YYYY") ' Форматируем дату
                ' Собираем ФИО ребенка, исключая последнюю часть, если это дата
                If UBound(parts) > 0 Then ' Если есть другие части кроме даты
                    For j = LBound(parts) To UBound(parts) - 1
                        childName = childName & parts(j) & " "
                    Next j
                    childName = Trim(childName)
                Else ' Если только одна часть и это дата, то что-то не так, берем всю ячейку как имя
                    childName = currentCellVal
                End If
            Else
                ' Вся ячейка - ФИО ребенка, дата рождения, возможно, в следующей строке
                childName = currentCellVal
            End If
        Else
            childName = currentCellVal ' Если Split вернул пустой массив (редкий случай)
        End If


        ' Проверяем следующую строку на да

ту рождения ребенка, если она еще не была найдена
        If childDOB = "" And i + 1 <= lastRowOriginal And IsDate(wsOriginal.Cells(i + 1, 1).Value) Then
            childDOB = Format(CDate(wsOriginal.Cells(i + 1, 1).Value), "DD.MM.YYYY")
        End If

        currentParentInfoRow = i ' Начинаем сканировать информацию о родителях с текущей строки ребенка

        ' 2. Собираем информацию о родителях и их датах рождения
        Do While currentParentInfoRow <= lastRowOriginal
            Dim isNextChild As Boolean
            isNextChild = False

            ' Проверяем, не является ли текущая строка началом новой записи о ребенке
            ' (если в столбце A есть текст, не являющийся датой, и это не текущая строка ребенка)
            If currentParentInfoRow > i And Not IsEmpty(wsOriginal.Cells(currentParentInfoRow, 1).Value) Then
                If Not IsDate(wsOriginal.Cells(currentParentInfoRow, 1).Value) Then
                    ' Это может быть новая запись о ребенке, проверим следующую за ней
                    If currentParentInfoRow + 1 <= lastRowOriginal Then
                        ' Если следующая строка в столбце A является датой, то это точно новая запись о ребенке
                        If IsDate(wsOriginal.Cells(currentParentInfoRow + 1, 1).Value) Then
                            isNextChild = True
                        Else
                            ' Если следующая строка в A не дата, но текущая строка A содержит
                            ' потенциальное ФИО ребенка и B/C пусты, тоже считаем новой записью
                            If IsEmpty(wsOriginal.Cells(currentParentInfoRow, 2).Value) And IsEmpty(wsOriginal.Cells(currentParentInfoRow, 3).Value) Then
                                isNextChild = True
                            End If
                        End If
                    Else
                        ' Это последняя строка, и в A есть текст, скорее всего, новый ребенок
                        isNextChild = True
                    End If
                End If
            End If

            If isNextChild Then
                Exit Do ' Нашли следующего ребенка, прекращаем сбор данных о родителях для текущего
            End If

            ' Обрабатываем информацию о родителе из столбца B
            If Not IsEmpty(wsOriginal.Cells(currentParentInfoRow, 2).Value) Then
                parentInfo = Trim(wsOriginal.Cells(currentParentInfoRow, 2).Value)
                If InStr(1, parentInfo, "-") > 0 Then
                    Dim parentParts() As String
                    parentParts = Split(parentInfo, "-")
                    relation = Trim(parentParts(0))
                    parentName = Trim(parentParts(1))

                    If parentName = "" Or parentName = "-" Or parentName = " " Then
                        parentName = ""
                    End If

                    ' Ищем дату рождения родителя в столбце C на той же строке
                    tempParentDOB = ""
                    If Not IsEmpty(wsOriginal.Cells(currentParentInfoRow, 3).Value) And IsDate(wsOriginal.Cells(currentParentInfoRow, 3).Value) Then
                        tempParentDOB = Format(CDate(wsOriginal.Cells(currentParentInfoRow, 3).Value), "DD.MM.YYYY")
                    End If

                    If parentName <> "" Then
                        ' Добавляем информацию о родителе в коллекцию.
                        ' Используем родство+имя как уникальный ключ, чтобы избежать дубликатов.
                        On Error Resume Next
                        parentsCollection.Add Array(relation, parentName, tempParentDOB), relation & "|" & parentName
                        On Error GoTo 0
                    End If
                End If
            End If

            currentParentInfoRow = currentParentInfoRow + 1 ' Переходим к следующей строке для поиска родителей
        Loop

        ' 3. Выбор одного родственника согласно приоритету
        Dim selectedRelation As String
        Dim selectedParentName As String
        Dim selectedParentDOB As String

        selectedRelation = ""
  

      selectedParentName = ""
        selectedParentDOB = ""
        foundParent = False

        ' Приоритет: мать, отец, отчим, бабушка, дедушка
        Dim priorityOrder() As String
        priorityOrder = Split("мать,отец,отчим,бабушка,дедушка", ",")

        For Dim p As Long To UBound(priorityOrder)
            For Each parentDetail In parentsCollection
                If LCase(Trim(parentDetail(0))) = Trim(priorityOrder(p)) Then
                    ' Проверяем, чтобы имя родителя не было пустым/прочерком
                    If Trim(parentDetail(1)) <> "" And Trim(parentDetail(1)) <> "-" And Trim(parentDetail(1)) <> " " Then
                        selectedRelation = parentDetail(0)
                        selectedParentName = parentDetail(1)
                        selectedParentDOB = parentDetail(2)
                        foundParent = True
                        Exit For ' Найден родитель по приоритету, выходим из внутреннего цикла
                    End If
                End If
            Next parentDetail
            If foundParent Then Exit For ' Найден родитель по приоритету, выходим из внешнего цикла
        Next p

        ' Если никого не нашли по приоритету, но есть другие родственники, взять первого попавшегося не пустого
        If Not foundParent And parentsCollection.Count > 0 Then
            For Each parentDetail In parentsCollection
                If Trim(parentDetail(1)) <> "" And Trim(parentDetail(1)) <> "-" And Trim(parentDetail(1)) <> " " Then
                    selectedRelation = parentDetail(0)
                    selectedParentName = parentDetail(1)
                    selectedParentDOB = parentDetail(2)
                    Exit For
                End If
            Next parentDetail
        End If

        ' Запись данных в новый лист, если информация о ребенке найдена
        If childName <> "" Then
            wsNew.Cells(newRow, 1).Value = childName
            wsNew.Cells(newRow, 2).Value = childDOB
            wsNew.Cells(newRow, 3).Value = selectedRelation
            wsNew.Cells(newRow, 4).Value = selectedParentName
            wsNew.Cells(newRow, 5).Value = selectedParentDOB
            newRow = newRow + 1
        End If

        ' Перемещаем указатель основной строки к началу следующего блока данных о ребенке
        ' или к концу листа, если текущий блок был последним
        i = currentParentInfoRow
    Loop

    ' Автоматическая подгонка ширины столбцов
    wsNew.Columns("A:E").AutoFit

    MsgBox "Данные успешно обработаны и записаны на листе 'Обработанные Данные'.", vbInformation
End Sub Исправь код чтобы он работал без ошибок