---

Sub SplitTableToFiles()
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim lastRow As Long, r As Long
    Dim savePath As String
    Dim fileName As String
    Dim uchastok As String, address As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wsSource = ActiveSheet
    lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
    savePath = ThisWorkbook.Path & "\Разделенные_файлы\"
    
    If Dir(savePath, vbDirectory) = "" Then MkDir savePath
    
    For r = 2 To lastRow
        ' Проверяем, что строка не пустая и не служебная
        If wsSource.Cells(r, "B").Value <> "" And Not wsSource.Cells(r, "B").Value Like "*КРАСН*" Then
            uchastok = wsSource.Cells(r, "D").Text
            address = wsSource.Cells(r, "F").Text
            
            fileName = "Участок_" & uchastok & "_" & address
            fileName = Replace(fileName, "/", "_")
            fileName = Replace(fileName, "\", "_")
            fileName = Replace(fileName, ":", "_")
            
            ' Создаем новую книгу
            Set wbNew = Workbooks.Add(xlWBATWorksheet)
            
            ' Копируем шапку и текущую строку
            wsSource.Rows(1).Copy wbNew.Sheets(1).Rows(1)
            wsSource.Rows(r).Copy wbNew.Sheets(1).Rows(2)
            
            ' Сохраняем и закрываем
            wbNew.SaveAs fileName:=savePath & fileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            wbNew.Close SaveChanges:=False
        End If
    Next r
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "Готово! Все файлы сохранены в папку 'Разделенные_файлы'", vbInformation
End Sub