Private Sub Workbook_Open()
Dim Arr, sSh
Arr = Array("Лист1", "Лист2")
For Each sSh In Arr
Protect_for_User_Non_for_VBA Me.Sheets(sSh)
Next
End Sub
Sub Protect_for_User_Non_for_VBA(wsSh As Worksheet)
wsSh.Protect Password:="1111", AllowFiltering:=True, UserInterfaceOnly:=True
End Sub

Dim nFolder As Object
Set nFolder = CreateObject("Scripting.FileSystemObject")
With nFolder
.CreateFolder ("D:\" & Cells(iLastRow, 1))
For i = 1 To 1
Next
End With

Dim objFSO As Object, objFile As Object
Dim sFileName12 As String, sNewFileName12 As String
sFileName12 = UserForm1.TextBox12.Text
sNewFileName12 = iLastRow - 2 & "KP.pdf"
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(sFileName12) = False Then
MsgBox "Такого файла не существует", vbCritical, "Внимание"
Exit Sub
End If
Set objFile = objFSO.GetFile(sFileName12)
objFile.Name = sNewFileName12
MsgBox "Файл переименован", vbInformation, "Сообщение"

Dim sNewFolderName12 As String
sFileName12 = "D:\" & sNewFileName12
sNewFolderName12 = nFolder  ' адрес куда перемещать - см. фото ошибки (во вложении)
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(sFileName12) = False Then
MsgBox "Такого файла не существует", vbCritical, "Внимание"
Exit Sub
End If
Set objFile = objFSO.GetFile(sFileName12)
objFile.Move sNewFolderName12
MsgBox "Файл перемещен", vbInformation, "Сообщение"

Private Sub Workbook_Open()
Dim iLastRow As Long
Dim i As Integer
With Sheet("Пример")
iLastRow = .Cells(Rows.Count, 5).End(xlDown).Row
For i = 3 To iLastRow
If .Cells(i, 5).Value <= Date Then
.Range("A" & i & ":G" & i).Interior.Color = RGB(255, 225, 225)
End If
End With
End Sub

Private Sub CommandButton1_Click()
With Worksheets("Лист1")
    i = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
    .Cells(i, 1) = UserForm1.TextBox1.Value
    .Cells(i, 2) = UserForm1.TextBox2.Value
End With
'Очистка формы для дальнейшего ввода данных
Me.TextBox1 = ""
Me.TextBox1.BackColor = &H80000005
Me.TextBox2 = ""
Me.TextBox2.BackColor = &H80000005
End Sub

Private Sub UserForm_Initialize()
     With TextBox2 'кнопка для доп информации
        .DropButtonStyle = fmDropButtonStyleReduce  'вид кнопки
        .ShowDropButtonWhen = fmShowDropButtonWhenAlways    'показывать кнопку
     End With
End Sub

Private Sub TextBox2_DropButtonClick()
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Clear
        .Filters.Add "PDF files", "*.pdf*"
        .AllowMultiSelect = False
        .InitialFileName = ThisWorkbook.Path
        If .Show = 0 Then Exit Sub
        TextBox2 = .SelectedItems(1)
    End With
End Sub

Dim WshNetwork As Object, sCompName As String, oUser As Object, sName
Set WshNetwork = CreateObject("WScript.Network")
sCompName = WshNetwork.ComputerName  'получаем имя компа
sName = WshNetwork.UserName          'получаем имя текущего пользователя
On Error Resume Next
'sName - имя пользователя на компьюторе
Set oUser = WshNetwork.GetObject("WinNT://" & sCompName & "/" & sName)
oUser.ChangePassword PassOld, "2584"
'ввод нового пароля
oUser.SetInfo

Private Sub CommandButton1_Click()
    MsgBox UserForm1.TextBox1.Text, 64, "Сообщение"
End Sub

Private Sub UserForm_Initialize()
    Dim CO_, GO_, DN_
        Set CO_ = CreateObject("ADSystemInfo")
        Set GO_ = GetObject("LDAP://" & CO_.UserName)
        DN_ = GO_.DisplayName
        UserForm1.TextBox1 = DN_
End Sub

Private Sub TextBox1_Change()
    If Me.TextBox1.SetFocus = True Then
        Me.TextBox1.BackColor = vbRed
    End If
End Sub

=СУММЕСЛИМН(B2:B87;C2:C87;"Посредник";A2:A87;"<="&F2;A2:A87;">="&F3)

Sub Сводная()
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Лист1!R2C1:R21C12", Version:=7).CreatePivotTable TableDestination:= _
        "Лист2!R1C1", TableName:="Пример", DefaultVersion:=7
End Sub

Sub Сводная()
    iST = Cells(Rows.Count, 1).End(xlUp).Row
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
    "Лист1!R1C1:R" & iST & "C12", Version:=7).CreatePivotTable TableDestination:= _
    "Лист2!R1C1", TableName:="Пример", DefaultVersion:=7
End Sub

Sub Сравнить()
    LR = Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row + 1
    For i = 3 To Worksheets("Лист1").Cells(Rows.Count, 8).End(xlUp).Row
    
    E = True
        For j = 2 To Worksheets("Лист2").Cells(Rows.Count, 1).End(xlUp).Row
            If Worksheets("Лист2").Cells(j, 1).Value = Worksheets("Лист1").Cells(i, 8).Value Then E = False: Exit For
        Next j
    If E Then Worksheets("Лист2").Cells(LR, 1).Value = Worksheets("Лист1").Cells(i, 8).Value: LR = LR + 1
    Next i
End Sub

Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
   If Not IsNumeric(Chr$(KeyAscii)) Then
       KeyAscii = 0
   Else
       t = Me.TextBox2
       If t Like "##" Or t Like "##.##" Then t = t & "."
       Me.TextBox2 = t
   End If
End Sub
 
Private Sub TextBox2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
   On Local Error Resume Next
   t = Me.TextBox2
   If KeyCode = 8 And (Right(t, 1) = "." Or Right(t, 1) = " ") Then t = Left$(t, Len(t) - 2): KeyCode = 0
   If KeyCode <> 8 And KeyCode <> Asc(vbTab) And Len(t) >= 10 Then KeyCode = 0
   Me.TextBox2 = t
End Sub

Private Sub UserForm_Initialize()

ComboBox1.RowSource = "Справочник! A2:A1000"

With UserForm1.ComboBox2
  .AddItem "1"
  .AddItem "2"
  .AddItem "3"
  .AddItem "4"
End With

End Sub