Option Explicit
Sub SaveFiles()
Dim sh1 As Worksheet
Set sh1 = ActiveSheet
Dim wb As Workbook
Dim s As String
Application.DisplayAlerts = False
With sh1
Dim arr As Variant
Dim y As Long
y = .Cells(.Rows.Count, 1).End(xlUp).Row + 2
'If y = 1 Then Exit Sub
arr = .Range(.Cells(1, 1), .Cells(y, 3))
Dim n As Variant
Dim e As Variant
y = 1
Do
If y > UBound(arr, 1) Then Exit Do
e = y
Do
If e > UBound(arr, 1) Then Exit Do
If arr(e, 1) = "N" Then Exit Do
e = e + 1
Loop
e = e + 1
Do
If e > UBound(arr, 1) Then Exit Do
If arr(e, 1) = "N" Then Exit Do
e = e + 1
Loop
e = e - 1
Do
If e < LBound(arr, 1) Then Exit Do
If .Cells(e, 1).Interior.ColorIndex <> -4142 Then Exit Do
e = e - 1
Loop
n = e
Do
If n < LBound(arr, 1) Then Exit Do
If Trim(arr(n, 3)) <> "" Then Exit Do
n = n - 1
Loop
Cells(y, 1).Select
'.Range(Cells(y, 1), Cells(e, 1)).EntireRow
Set wb = Workbooks.Add(1)
.Copy Before:=wb.Sheets(1)
wb.Sheets(2).Delete
With wb.Sheets(1)
If y > 1 Then
With .Range(.Cells(1, 1), .Cells(y, 1)).EntireRow
.Clear
.Hidden = True
End With
End If
With .Range(.Cells(e + 1, 1), .Cells(UBound(arr, 1) - 1, 1)).EntireRow
.Clear
.Hidden = True
End With
End With
s = Trim(arr(n, 3))
s = s & ".xlsx"
On Error Resume Next
Workbooks(s).Close
On Error GoTo 0
s = .Parent.Path & "\" & s
If Dir(s) <> "" Then Kill s
wb.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
wb.Close False
y = e + 1
Loop
End With
Application.DisplayAlerts = True
End Sub
Не стоит стесняться. Мы тут все нет-нет и занимаемся этим. Некоторых прям за уши не оттащишь, дай только этим позаниматься. )
Alt+F11 Правый клик на "ЭтаКнига" (это вверху слева). Insert - Module В появившееся окно вставляете код с форума. Возвращаетесь в Excel - клик на любую ячейку. Alt+F11 Выбрать макрос. Выполнить.