Sub Макрос3()
'

    Sheets("база").Select
'    Application.AddCustomList ListArray:=Array("сын", "сын сына", "сын сына сына", _
'        "дочь", "2 дочери", "дочь сына", "2 дочери сына", "отец", "отец отца", "мать", _
'        "мать отца", "мать матери", "муж", "жена", "брат", "брат по отцу", "сестра", _
'        "сестра по отцу", "2 сестры", "2 сестры по отцу", "брат по матери", _
'        "сестра по матери", "2 брата по матери", "2 сестры по матери", _
'        "брат и сестра по матери", "брат отца(дядя)")
    ActiveWorkbook.Worksheets("база").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("база").Sort.SortFields.Add2 Key:=Range("A2:F2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "сын,сын сына,сын сына сына,дочь,2 дочери,дочь сына,2 дочери сына,отец,отец отца,мать,мать отца,мать матери,муж,жена,брат,брат по отцу,сестра,сестра по отцу,2 сестры,2 сестры по отцу,брат по матери,сестра по матери,2 брата по матери,2 сестры по матери,брат и сестра по матери,брат отца(дядя)" _
        , DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("база").Sort
        .SetRange Range("A2:F2")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Sub Макрос4()

Dim r As Range

Application.ScreenUpdating = False

    For Each r In Range("A2:F13254").Rows
    ActiveWorkbook.Worksheets("база").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("база").Sort.SortFields.Add2 Key:=r, _
        SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
        "сын,сын сына,сын сына сына,дочь,2 дочери,дочь сына,2 дочери сына,отец,отец отца,мать,мать отца,мать матери,муж,жена,брат,брат по отцу,сестра,сестра по отцу,2 сестры,2 сестры по отцу,брат по матери,сестра по матери,2 брата по матери,2 сестры по матери,брат и сестра по матери,брат отца(дядя)" _
        , DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("база").Sort
        .SetRange r
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlLeftToRight
        .SortMethod = xlPinYin
        .Apply
    End With
    Next
    
Application.ScreenUpdating = True

End Sub