lst.ListRows.Add
 Range("table[Date]") = Now

Private Sub Workbook_BeforeClose(Cancel As Boolean)
ThisWorkbook.Save
End Sub

Sub DoinSelectedSheets()
    Dim sh As Worksheet
    Dim rn As Range
    Dim AW As Window
    Set AW = ActiveWindow
    Set rn = Worksheets("ИТОГ").Range("2:2")
    For Each sh In AW.SelectedSheets
                sh.Select
                sh.Unprotect
 'Начало тела цикла
    rn.Copy Destination:=sh.[a2]
 'Конец тела цикла
    ActiveWindow.Zoom = 75
               sh.Protect
         
    Next
End Sub

Sub new_sh_after()
Dim i As Object
On Error Resume Next
Finalrow = Range("A1048576").End(xlUp).Row
 For Each i In Sheets("17").Range("A1:A" & Finalrow)
Err.Clear
 Sheets("Pivot").Select
    ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
        ClearAllFilters
    ActiveSheet.PivotTables("СводнаяТаблица1").PivotFields("ФИО"). _
        CurrentPage = i.Value
 If Err.Number = 0 Then
 Sheets("Pivot").Range(Range("A4"), Range("B4").End(xlDown)).Copy
   
   
  Worksheets.Add(after:=Worksheets("17")).Name = Left(i, 31)
   ActiveSheet.Range("A1").Select
     
    With Selection
 .PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    End With
      
    Else
    nm = nm & i.Value & ", "
    
End If
Next i
  MsgBox "Следующих ФИО нет в базе:" & Chr(10) & nm
End Sub

Sub добавить()
Set rn = Range("A9:S9")
With Sheets("Лист2")
lr = .Cells(Rows.Count, 1).End(xlUp).Row + 1
.Unprotect "123"
.Range("A" & lr & ":S" & lr) = rn.Value
.Protect "123"
End With
End Sub

Sub добавить()
Range("A9:S9").Copy
With Sheets("Лист2")
.Range("A" & .Cells(Rows.Count, 1).End(xlUp).Row + 1).PasteSpecial xlValues
End With
End Sub

Sub ZonaDostavki()
Application.ScreenUpdating = False
Set shMain = Sheets("Лист1")
lr = shMain.Cells(Rows.Count, "d").End(xlUp).Row
For i = 2 To lr
    If shMain.Range("d" & i) <> shMain.Range("d" & i - 1) Then
    k = 1
        'Set wb = Workbooks.Add(1):
        Set sh = Worksheets.Add
        shMain.Rows(1).Copy
        sh.Range("A1").PasteSpecial xlPasteAll
        'wb.SaveAs ThisWorkbook.Path & "\" & shMain.Range("d" & i) & " .xlsx", FileFormat:=xlOpenXMLWorkbook
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        'If shMain.Range("d" & i) <> shMain.Range("d" & i + 1) Then wb.Close True
    Else
        k = k + 1
        sh.Rows(k) = shMain.Rows(i).Value
        'If shMain.Range("d" & i) <> shMain.Range("d" & i + 1) Then wb.Close True
    End If
Next
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 1 Then Exit Sub
Cells(Target.Row, 5).Value = Application.UserName
End Sub

Sub test()
Dim i As Integer
Dim ilist As Integer
Dim xlbookname As String
Dim y As Integer
Set xlbook = ActiveWorkbook
Dim rng As Range
Set rng = xlbook.Sheets("Данные").Range("A1:M4")
For i = 1 To xlbook.Sheets("Список").Cells(Rows.Count, 1).End(xlUp).Row
xlbookname = xlbook.Sheets("Список").Cells(i, 1)
y = 5
Set xlbooknew = Workbooks.Add
rng.Copy Destination:=[a1]
For ilist = 1 To xlbook.Sheets("Данные").Cells(Rows.Count, 2).End(xlUp).Row
If xlbook.Sheets("Данные").Cells(ilist, 12) = xlbookname Then
xlbook.Sheets("Данные").Rows(ilist).Copy xlbooknew.Sheets(1).Rows(y)
y = y + 1
End If
Next
xlbooknew.SaveAs xlbook.Path & "\" & xlbookname & ".xls"
xlbooknew.Close
Next
End Sub

Sub usl4()
k = 3 'негатив-нейтрал-позитив
Dim arr()
Dim a()
ReDim a(1 To k)
a(1) = "negative"
a(2) = "neutral"
a(3) = "positive"
us = Val(InputBox("сколько вариантов?"))
ReDim arr(1 To us, 1 To k ^ us + 1)
'x = 4 + 3
q = 1

For y = 1 To us
For i = 2 To k ^ us + 1

arr(y, 1) = "усл" & y

For j = i To i + k ^ (us - y) - 1
arr(y, j) = a(q)
Next
If q = 3 Then q = 1 Else q = q + 1
i = i + k ^ (us - y) - 1
Next
Next
v = MsgBox("массив вариантов сформирован. Выгрузить на лист?", vbYesNo)

Select Case v
    Case vbNo: Exit Sub
    Case vbYes
    If k ^ us > Columns.Count Then MsgBox "недостаточно места": Exit Sub
    For l = 1 To us
    For x = 1 To k ^ us + 1
        Cells(l, x).Value = arr(l, x)
    Next
    Next
End Select

End Sub