Sub Макрос_InputBox()
 Dim password As String
  password = InputBox("Введите пароль:") '1. Юзер указывает пароль.
  If password = "" Then '2. Если юзер щёлкнул "Cancel" или если в поле пусто, то завершение работы макроса.
        Exit Sub
    End If
   If password <> "1234" Then '3. Проверка пароля. Если пароль неправильный, то завершение работы макроса.
        MsgBox "Неправильный пароль.", vbExclamation
        Exit Sub
    End If
    '4. Если пароль правильный.
    ' Здесь действия макроса.
   Макрос1
   
End Sub

Sub Копировать_по_журналам()
    Dim wb As Workbook, c As Range, arrWB(), w
    arrWB = Array("Журнал1.xlsm", "Журнал2.xlsm", "Журнал3.xlsm", "Журнал4.xlsm", "Журнал5.xlsm", "Журнал6.xlsm", "Журнал7.xlsm", "Журнал8.xlsm")
    With Application
       .EnableEvents = False
       .Calculation = xlCalculationManual
       .ScreenUpdating = False
       .Visible = False
         
        For Each w In arrWB

            Set wb = Workbooks.Open("E:\Сервер\Сервер 1\Сервер 2\Сервер 3\Сервер 4\РАБОЧИЕ\Журнал выездов" & "\" & w) ' Этот метод копирует данные в книги находящиеся по пути с главной
            ThisWorkbook.Worksheets("Средства измерений").Cells.Copy wb.Worksheets("Средства измерений").Cells 'копируем все данные с активного листа
            For Each c In wb.Worksheets("Средства измерений").Cells.SpecialCells(xlCellTypeFormulas, 23)
                c.FormulaLocal = Replace(c.FormulaLocal, "[" & ThisWorkbook.Name & "]", "")
            Next c
            wb.Close (True)
        Next w
         
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
        .Visible = True
    End With
    MsgBox "Готово"
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cl As Range
If Not Intersect(Target, [A1:C20]) Is Nothing Then
On Error Resume Next
For Each cl In Sheets("Лист2").Range("A1:A6").Cells
N = WorksheetFunction.Search(cl.Text, Target)
If Err = 0 Then
With Target.Characters(N, Len(cl)).Font

.FontStyle = "полужирный"

End With
Else
Err.Clear
End If
Next
End If
End Sub

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

 Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long

Sub MakeHyper() 'http://www.planetaexcel.ru/forum.php?thread_id=42349  
Dim LastRow As Long, i As Long, Adr As String, Str As String  
LastRow = Cells(Rows.Count, 2).End(xlUp).Row  
   For i = 2 To LastRow  
       Adr = Cells(i, 2).Value  
       Str = Split(Split(Cells(i, 2), "\")(UBound(Split(Cells(i, 2), "\"))), ".")(0)  
       Cells(i, 2).Hyperlinks.Add Anchor:=Cells(i, 2), Address:=Adr, TextToDisplay:=Str  
   Next  
End Sub

Sub Get_Value_From_Close_Book2()
    Dim sShName As String, sAddress As String, vData
    Dim objCloseBook As Object
    'Отключаем обновление экрана
    Application.ScreenUpdating = False
    Set objCloseBook = GetObject("C:\Книга12.xlsm")
    sAddress = "G8" 'или одна ячейка - "A1"
    'получаем значение
    vData = objCloseBook.Sheets("Лист1").Range(sAddress).Value
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [G8].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [G8] = vData
    End If
    Set objCloseBook = GetObject("C:\Книга12.xlsm")
    sAddress = "I10" 'или одна ячейка - "A1"
    'получаем значение
    vData = objCloseBook.Sheets("Лист1").Range(sAddress).Value
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [I10].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [I10] = vData
    End If
    Set objCloseBook = GetObject("C:\Книга12.xlsm")
    sAddress = "C14" 'или одна ячейка - "A1"
    'получаем значение
    vData = objCloseBook.Sheets("Лист2").Range(sAddress).Value
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [C14].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [C14] = vData
    End If
    Application.ScreenUpdating = True
End Sub

    Set objCloseBook = GetObject("C:\Книга12.xlsm")
    sAddress = "C14" 'или одна ячейка - "A1"
    'получаем значение
    vData = objCloseBook.Sheets("Лист2").Range(sAddress).Value
    objCloseBook.Close False
    'Записываем данные на активный лист книги,
    'с которой запустили макрос
    If IsArray(vData) Then
        [C14].Resize(UBound(vData, 1), UBound(vData, 2)).Value = vData
    Else
        [C14] = vData
    End If
    Application.ScreenUpdating = True