Sub Гиперссылка()

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
"onenote:///C:\Users\Павел_А\Documents\Записные%20книжки%20OneNote\Записная%20книжка%202019\Задачи\Задачи%202.one" _
, SubAddress:= _
"МояЗадача§ion-id={3A354F2D-F136-473D-8B62-1C1AD390B89D}&page-id={1CF9327F-4D7A-48CF-9E0C-7A323BB268EB}&object-id={5B5B808E-1" _
, TextToDisplay:="МояЗадача"

End Sub

Sub УФ() ' если выделенные ячейки будут изменены, то они зальются красным
Dim iCell As Range

Cells.FormatConditions.Delete
For Each iCell In Selection
    If Not IsEmpty(iCell) Then
        If IsNumeric(iCell.Value) Then
            iCell.FormatConditions.Add Type:=xlExpression, Formula1:="=" & iCell.Address & "<>" & iCell.Value
        Else
            iCell.FormatConditions.Add Type:=xlExpression, Formula1:="=" & iCell.Address & "<>""" & iCell.Text & """"
        End If
    Else
        iCell.FormatConditions.Add Type:=xlExpression, Formula1:="=НЕ(ЕПУСТО(" & iCell.Address & "))"
    End If
    iCell.FormatConditions(iCell.FormatConditions.Count).SetFirstPriority
    With iCell.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .Color = 255
        .TintAndShade = 0
    End With
    iCell.FormatConditions(1).StopIfTrue = False
Next
End Sub

Sub loadFile()
    Dim fPath As String
    Dim oXMLHTTP As Object
    Dim oADOStream As Object
    
    fPath = ActiveWorkbook.Path
    Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
    'подключение
'    .Open "POST", sURL, False, "login", "password" ' не требуется, аутентификация по IP
    oXMLHTTP.Open "GET", "http://IP-адрес_сервера/index.php?option=com_docman&task=doc_download&gid=35&Itemid", 0 ' URL адрес для загрузки
    'получение файла
    oXMLHTTP.Send
    Set oADOStream = CreateObject("ADODB.Stream")
    oADOStream.Mode = 3 'разрешение на чтение и запись
    oADOStream.Type = 1 'тип данных - Binary
    oADOStream.Open
    oADOStream.Write oXMLHTTP.responseBody
    'сохранение (с перезаписью файла при необходимости)
    oADOStream.SaveToFile fPath & "\FilesForProcessing\имя_файла.xlsm", 2 ' путь для сохранения файла, 2 - перезапись файла
End Sub

Sub Btn()
    With ActiveSheet.Buttons.Add(Left:=200, Top:=100, Width:=125, Height:=40)
     .Name = "Button 1"
     .Text = "Добавить столбцы"
     .OnAction = "addCol"
    End With
End Sub

Private Sub UserForm_Initialize()
   With Me.Controls.Add(bstrProgID:="Forms.CommandButton.1")
         .Name = "CommandButton1"
         .Left = 190
         .Top = 20
         .Height = 24
         .Width = 78
         .Caption = "Отменить"
    End With
    
    With Me.CodeModule
        Line = .CountOfLines
        .InsertLines Line + 1, "Sub CommandButton1_Click()"
        .InsertLines Line + 2, "НажатиеКнопки1"
        .InsertLines Line + 3, "End Sub"
    End With
End Sub

Sub НажатиеКнопки1 ()
    MsgBox "Кнопка нажата"
    UserForm5.Hide
End Sub

Sub Работает()
Dim FilePath As String
Dim FolderPath As String
Dim FolderName As String
Dim iExtension As String
Dim link As String ' новое имя папки
Dim check As Boolean
       
FilePath = "C:\Users\Павел\Desktop\БЗ\Бланки\Старое имя папки\Файл с данными.doc"

iExtension = CreateObject("Scripting.FileSystemObject").GetExtensionName(FilePath) ' Расширение файла
FolderPath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(FilePath) ' Имя родительской папки
FolderName = Replace(FolderPath, ThisWorkbook.Path & "\" & "Бланки" & "\", "") ' Имя папки для TextToDisplay гиперссылки
link = "Новое имя папки"
Name FolderPath As ThisWorkbook.Path & "\Бланки\" & link
End Sub

Sub Не_работает()
Dim FilePath As Variant
Dim FolderPath As String
Dim FolderName As String
Dim iExtension As String
Dim WordApp As Object, CopyArea As Variant
Dim link As String ' новое имя папки
Dim check As Boolean
   
ChDir ThisWorkbook.Path & "\" & "Бланки" & "\" ' Путь к папкам с бланками-заказами
FilePath = Application.GetOpenFilename("all Files (*.*), *.*", Title:="Выберите файл") ' Диалог выбора файла
If FilePath = False Then 'Если файл не выбран, то сбрасывается check, выводится сообщение и выход
    check = False
    MsgBox "Файл не выбран!", 48, "ВНИМАНИЕ!"
    Exit Sub
End If

iExtension = CreateObject("Scripting.FileSystemObject").GetExtensionName(FilePath) ' Расширение файла
FolderPath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(FilePath) ' путь к родительской папке
FolderName = Replace(FolderPath, ThisWorkbook.Path & "\" & "Бланки" & "\", "") ' Имя папки для TextToDisplay гиперссылки
link = "Новое имя папки" ' в данном макросе равно FolderName
Name FolderPath As ThisWorkbook.Path & "\Бланки\" & link
End Sub