---

Sub SplitToFilesByAddress()
    Dim wsSource As Worksheet
    Dim wbNew As Workbook
    Dim wsNew As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim addressVal As String
    Dim safeFileName As String
    Dim savePath As String
    
    ' Проверка, сохранен ли текущий файл
    If ThisWorkbook.Path = "" Then
        MsgBox "Пожалуйста, сначала сохраните этот файл в какую-нибудь папку на ПК, а потом запускайте макрос.", vbExclamation
        Exit Sub
    End If
    
    ' Папка для сохранения (создастся там же, где лежит твой файл)
    savePath = ThisWorkbook.Path & "\Разделенные_Адреса\"
    If Dir(savePath, vbDirectory) = "" Then
        MkDir savePath
    End If
    
    Set wsSource = ThisWorkbook.ActiveSheet
    ' Ищем последнюю заполненную строку по колонке B (ФИО)
    lastRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row
    
    ' Отключаем обновление экрана, чтобы макрос не "моргал" и работал в разы быстрее
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For i = 2 To lastRow ' Начинаем со 2 строки, так как 1-я — это шапка
        addressVal = wsSource.Cells(i, 6).Text ' Колонка F (6 по счету) — это Адрес
        
        If Trim(addressVal) <> "" Then
            ' Очищаем имя от спецсимволов, которые Windows не разрешает в именах файлов
            safeFileName = addressVal
            safeFileName = Replace(safeFileName, "/", "_")
            safeFileName = Replace(safeFileName, "\", "_")
            safeFileName = Replace(safeFileName, ":", "_")
            safeFileName = Replace(safeFileName, "*", "_")
            safeFileName = Replace(safeFileName, "?", "_")
            safeFileName = Replace(safeFileName, """", "_")
            safeFileName = Replace(safeFileName, "<", "_")
            safeFileName = Replace(safeFileName, ">", "_")
            safeFileName = Replace(safeFileName, "|", "_")
            
            ' Создаем новый файл
            Set wbNew = Workbooks.Add
            Set wsNew = wbNew.Sheets(1)
            
            ' Копируем шапку (строка 1) с шириной колонок и цветами
            wsSource.Rows(1).Copy
            wsNew.Rows(1).PasteSpecial Paste:=xlPasteAll
            wsNew.Rows(1).PasteSpecial Paste:=xlPasteColumnWidths
            
            ' Копируем текущую строку с данными
            wsSource.Rows(i).Copy
            wsNew.Rows(2).PasteSpecial Paste:=xlPasteAll
            
            ' Сохраняем и закрываем новый файл
            wbNew.SaveAs Filename:=savePath & safeFileName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            wbNew.Close SaveChanges:=False
        End If
    Next i
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "Готово! Создано файлов: " & (lastRow - 1) & vbCrLf & "Ищите их в папке: " & savePath, vbInformation
End Sub