Sub ProcessFamilyData()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim LastRow As Long, i As Long, DestRow As Long
    Dim childInfo As String, parentType As String, fullName As String
    Dim childParts() As String, CleanedDate As String
    Dim DashPos As Integer, cellValue As String
    Dim childLastName As String, childFirstName As String, childMiddleName As String, childBirthDate As String
    
    ' Установить исходный лист
    Set wsSrc = ActiveSheet
    
    ' Создать новый лист для результатов
    On Error Resume Next
    Application.DisplayAlerts = False
    Worksheets("Родители").Delete
    Application.DisplayAlerts = True
    On Error GoTo 0
    
    Set wsDest = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    wsDest.Name = "Родители"
    
    ' Заголовки (добавлены колонки для данных ребенка)
    With wsDest
        .Range("A1:K1") = Array("Исх.строка", "Фамилия реб.", "Имя реб.", "Отчество реб.", "Дата рожд. реб.", _
                                "Тип родителя", "Фамилия родит.", "Имя родит.", "Отчество родит.", "Дата рожд. родит.")
        .Rows(1).Font.Bold = True
        .Rows(1).Interior.Color = RGB(200, 220, 255)
        .Columns("A:K").AutoFit
    End With
    
    ' Найти последнюю строку с данными
    LastRow = wsSrc.Cells(wsSrc.Rows.Count, "A").End(xlUp).row
    DestRow = 2
    
    ' Обработать каждую строку
    For i = 1 To LastRow
        ' Определяем строку с данными ребенка
        If Not IsEmpty(wsSrc.Cells(i, "A")) And Not IsEmpty(wsSrc.Cells(i, "B")) Then
            childInfo = Trim(wsSrc.Cells(i, "B").value)
            
            ' Разбиваем данные ребенка на компоненты
            ParseChildInfo childInfo, childLastName, childFirstName, childMiddleName, childBirthDate
            
            ' Обработка ОТЦА (в той же строке)
            If Not IsEmpty(wsSrc.Cells(i, "C")) Then
                cellValue = Trim(wsSrc.Cells(i, "C").value)
                
                ' Проверяем наличие данных об отце
                If InStr(1, cellValue, "отец", vbTextCompare) > 0 Then
                    parentType = "03 Отец"
                    
                    ' Извлекаем ФИО родителя
                    DashPos = InStr(cellValue, "–")
                    If DashPos = 0 Then DashPos = InStr(cellValue, "-")
                    If DashPos = 0 Then DashPos = InStr(cellValue, ":")
                    
                    If DashPos > 0 Then
                        fullName = Trim(Mid(cellValue, DashPos + 1))
                        CleanedDate = FormatDate(Trim(wsSrc.Cells(i, "D").value))
                        
                        ' Записать данные отца
                        WriteParentRecord wsDest, DestRow, i, childLastName, childFirstName, _
                                          childMiddleName, childBirthDate, childInfo, _
                                          parentType, fullName, CleanedDate
                        DestRow = DestRow + 1
                    End If
                End If
            End If
            
            ' Обработка МАТЕРИ (в следующей строке)
            If i + 1 <= LastRow Then
                If Not IsEmpty(wsSrc.Cells(i + 1, "C")) Then
                    cellValue = Trim(wsSrc.Cells(i + 1, "C").value)
                    
                    ' Проверяем наличие данных о матери
                    If InStr(1, cellValue, "мать", vbTextCompare) > 0 Then
                        parentType = "04 Мать"
                        
                        ' Извлекаем ФИО родителя
                        DashPos = InStr(cellValue, "–")
                        If DashPos = 0 Then DashPos = InStr(cellValue, "-")
                        If DashPos = 0 Then DashPos = InStr(cellValue, ":")
                        
                        If DashPos > 0 Then
                        fullName = Trim(Mid(cellValue, DashPos + 1))
                            CleanedDate = FormatDate(Trim(wsSrc.Cells(i + 1, "D").value))
                            
                            ' Записать данные матери
                            WriteParentRecord wsDest, DestRow, i + 1, childLastName, childFirstName, _
                                              childMiddleName, childBirthDate, childInfo, _
                                              parentType, fullName, CleanedDate
                            DestRow = DestRow + 1
                        End If
                    End If
                End If
            End If
        End If
    Next i
    
    ' Форматирование результатов
    With wsDest
        If DestRow > 2 Then
            .Columns("A:K").AutoFit
            .Columns("K").ColumnWidth = 40  ' Ширина для исходных данных ребенка
            .Columns("E").NumberFormat = "dd.mm.yyyy"  ' Формат даты рождения ребенка
            .Columns("J").NumberFormat = "dd.mm.yyyy"  ' Формат даты рождения родителя
            .Columns("E").HorizontalAlignment = xlCenter
            .Columns("J").HorizontalAlignment = xlCenter
        Else
            .Range("A2").value = "Данные не найдены"
        End If
    End With
    
    MsgBox "Обработка завершена! Создано " & DestRow - 2 & " записей.", vbInformation
End Sub

' Функция для разбора данных ребенка
Sub ParseChildInfo(childInfo As String, ByRef lastName As String, ByRef firstName As String, _
                  ByRef middleName As String, ByRef birthDate As String)
    Dim parts() As String
    Dim i As Integer, dateStart As Integer
    
    ' Инициализация
    lastName = ""
    firstName = ""
    middleName = ""
    birthDate = ""
    
    ' Разделяем строку по пробелам
    parts = Split(Trim(childInfo), " ")
    
    ' Ищем начало даты (формат dd.mm.yyyy)
    dateStart = -1
    For i = UBound(parts) To 0 Step -1
        If IsDate(Replace(parts(i), ".", "/")) And Len(parts(i)) >= 8 Then
            dateStart = i
            Exit For
        End If
    Next i
    
    ' Извлекаем дату рождения
    If dateStart >= 0 Then
        birthDate = FormatDate(parts(dateStart))
        
        ' Извлекаем ФИО (все части до даты)
        Select Case dateStart
            Case 0
                ' Только дата
            Case 1
                lastName = parts(0)
            Case 2
                lastName = parts(0)
                firstName = parts(1)
            Case 3
                lastName = parts(0)
                firstName = parts(1)
                middleName = parts(2)
            Case Else
                lastName = parts(0)
                firstName = parts(1)
                For i = 2 To dateStart - 1
                    middleName = middleName & " " & parts(i)
                Next i
                middleName = Trim(middleName)
        End Select
    Else
        ' Если дату не нашли, пытаемся извлечь ФИО из всех частей
        Select Case UBound(parts)
            Case 0
                lastName = parts(0)
            Case 1
                lastName = parts(0)
                firstName = parts(1)
            Case 2
                lastName = parts(0)
                firstName = parts(1)
                middleName = parts(2)
            Case Else
                lastName = parts(0)
                firstName = parts(1)
                For i = 2 To UBound(parts)
                    middleName = middleName & " " & parts(i)
                Next i
                middleName = Trim(middleName)
        End Select
    End If
End Sub

' Функция для записи данных родителя
Sub WriteParentRecord(ws As Worksheet, row As Long, srcRow As Long, _
childLastName As String, childFirstName As String, childMiddleName As String, childBirthDate As String, _
childFullInfo As String, parentType As String, parentFullName As String, parentBirthDate As String)
    Dim lastName As String, firstName As String, middleName As String
    Dim spacePos1 As Integer, spacePos2 As Integer
    
    ' Очистка имени родителя от лишних символов
    parentFullName = Replace(parentFullName, "–", "")
    parentFullName = Replace(parentFullName, "-", "")
    parentFullName = Replace(parentFullName, "  ", " ")
    parentFullName = Application.WorksheetFunction.Trim(parentFullName)
    
    ' Обработка пустого имени
    If parentFullName = "" Then
        lastName = ""
        firstName = ""
        middleName = ""
    Else
        ' Находим первое и второе пробелы
        spacePos1 = InStr(parentFullName, " ")
        spacePos2 = InStr(spacePos1 + 1, parentFullName, " ")
        
        ' Разделяем ФИО на компоненты
        If spacePos1 > 0 Then
            lastName = Left(parentFullName, spacePos1 - 1)
            
            If spacePos2 > 0 Then
                firstName = Mid(parentFullName, spacePos1 + 1, spacePos2 - spacePos1 - 1)
                middleName = Mid(parentFullName, spacePos2 + 1)
            Else
                firstName = Mid(parentFullName, spacePos1 + 1)
                middleName = ""
            End If
        Else
            lastName = parentFullName
            firstName = ""
            middleName = ""
        End If
    End If
    
    ' Запись данных
    With ws
        .Cells(row, 1).value = srcRow                                       ' Исходная строка
        .Cells(row, 2).value = childLastName                                ' Фамилия ребенка
        .Cells(row, 3).value = childFirstName                               ' Имя ребенка
        .Cells(row, 4).value = childMiddleName                              ' Отчество ребенка
        .Cells(row, 5).value = childBirthDate                               ' Дата рождения ребенка
        .Cells(row, 6).value = parentType                                   ' Тип родителя
        .Cells(row, 7).value = lastName                                     ' Фамилия родителя
        .Cells(row, 8).value = firstName                                    ' Имя родителя
        .Cells(row, 9).value = middleName                                   ' Отчество родителя
        .Cells(row, 10).value = parentBirthDate                             ' Дата рождения родителя
        
        ' Форматирование дат
        If IsDate(.Cells(row, 5).value) Then .Cells(row, 5).NumberFormat = "dd.mm.yyyy"
        If IsDate(.Cells(row, 10).value) Then .Cells(row, 10).NumberFormat = "dd.mm.yyyy"
    End With
End Sub

' Функция для очистки и форматирования даты
Function FormatDate(rawDate As String) As String
    If rawDate = "" Then Exit Function
    
    Dim Cleaned As String, result As String
    Dim i As Integer
    
    ' Удаление пробелов и лишних точек
    Cleaned = Replace(rawDate, " ", "")
    Cleaned = Replace(Cleaned, ". ", ".")
    Cleaned = Replace(Cleaned, " .", ".")
    Cleaned = Replace(Cleaned, ",", ".")
    
    ' Удаление нечисловых символов (кроме точек)
    For i = 1 To Len(Cleaned)
        If IsNumeric(Mid(Cleaned, i, 1)) Or Mid(Cleaned, i, 1) = "." Then
            result = result & Mid(Cleaned, i, 1)
        End If
    Next i
    Cleaned = result
    
    ' Проверка формата
    If IsDate(Cleaned) Then
        FormatDate = Format(CDate(Cleaned), "dd.mm.yyyy")
    Else
        ' Попытка восстановить дату
        If Len(Cleaned) = 8 And IsNumeric(Cleaned) Then
            FormatDate = Format(Left(Cleaned, 2) & "/" & Mid(Cleaned, 3, 2) & "/" & Right(Cleaned, 4), "dd.mm.yyyy")
        Else
            FormatDate = rawDate
        End If
    End If
End Function
Сделай так что бы этот код не пропускал пустые строчки если там нет мамы или отца, а так же вносил если там есть отчим, бабушка или дедушка, а если никого вообще нет ставил сирота