Worksheets("List1").Protect Password:="555"

Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Worksheets("List1").Unprotect Password:="555"
'много ячеек подверженных изменению
    Set KeyCells = Range("B1")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
    Is Nothing Then
'необходимые действия    
    Set KeyCells = Range("B2")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
    Is Nothing Then
'необходимые действия
'и так далее
Worksheets("List1").Protect Password:="555"
End Sub

    'Заполняем поля посещения стран автоматически
Private Sub Worksheet_Change(ByVal Target As Range)
    Set KeyCells = Range("A2")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
    Is Nothing Then
Application.ScreenUpdating = False

    Dim str As String
    Dim i As Long
    For i = 0 To Range("A2").Count - 1
        If Range("A2").Select Then
          str = str & Range("A2").Value & ", "
        End If
     Next
        Range("A3").Value = Range("A3").Value & str
   End If
End Sub

Private Sub X1_Click()
   If X1.Value = True Then
      X2.Value = False
      X3.Value = False
      X4.Value = False
   End If
End Sub

For n = 2 To 4
("X" & n).Value = False
Next n

For u = 0 To 3
         If u = 1 Then: Swar = Sheets("List").Range("FG22"): GoTo Enter:
         If u = 2 Then: Swar = Sheets("List").Range("FH22"): GoTo Enter:
         If u = 3 Then: Swar = Sheets("List").Range("FI22"): GoTo Enter:
         If u = 0 Then: Swar = Sheets("List").Range("FF22"): GoTo Enter:
    Next u
Enter: 
    Select Case i
    Case Is < 0
       Toggle1 = False
    Case Is = 0
       Cells(3 + u, 2).Value = Swar
    Case Is <= 17 - j
       Cells(3 + u, (1 + i) + (j - 1)).Value = Swar
    Case Is <= 33 - j
       Cells(8 + u, (1 + i) - (17 - j)).Value = Swar
    Case Is <= 49 - j
       Cells(13 + u, (1 + i) - (33 - j)).Value = Swar
    Case Is <= 65 - j
       Cells(18 + u, (1 + i) - (49 - j)).Value = Swar
    Case Is <= 81 - j - (17 - j)
       Cells(23 + u, (1 + i) - (65 - j)).Value = Swar
    Case Is > 81 - j - (17 - j)
       Toggle1 = False
    End Select

ActiveWorkbook.Sheets("List").ToggleButton1.Value = True 

Sub Converter()
'проверка наличия скрипта в директории C:\WINDOWS
If Dir("C:\WINDOWS\mf2tXP.exe") = "" Then
    MsgBox "Для продолжения работы" & vbNewLine & "установите приложение:" & vbNewLine & "C:\WINDOWS\mf2tXP.exe" & vbNewLine & "", vbCritical, "Ошибка"
    Exit Sub
End If
    On Error Resume Next
        'открываем диалоговое окно выбора файла *.mid
    FOpen$ = Application.GetOpenFilename(FileFilter:="Text Files (*.mid), *.mid")
        If VarType(FOpen$) = vbBoolean Then Exit Sub
    'создаем пустой текстовый файл для дальнейшей конвертации
    MyPath$ = "C:\Temp\"
    MkDir MyPath$
        Set fso = CreateObject("scripting.filesystemobject")
        Set ts = fso.CreateTextFile(MyPath$ & ".txt", True)
        ts.Close
    'назначаем директорию скрипта
    Const PATH = "C:\WINDOWS\"
    'проверка хода выполнения скрипта с помощью сообщения
       MsgBox PATH & "mf2tXP.exe " & FOpen$ & " " & MyPath$ & ".txt", vbInformation, "Проверка выполнения скрипта"
    'запрускаем непосредственно сам скрипт и назначаем ему файл для конвертации и результирующий файл
    CreateObject("wscript.shell").Run PATH & "mf2tXP.exe " & FOpen$ & " " & MyPath$ & ".txt", 0, True
    Set ts = Nothing: Set fso = Nothing
    'даем пользователю знать что файлы созданы и перемещены в папку
        MsgBox "Файлы созданы, и помещены в папку" & vbNewLine & MyPath$, vbInformation, "Готово!"
    ' открываем саму папку с созданным файлом
    CreateObject("wscript.shell").Run "explorer.exe /e, """ & MyPath$ & """"
End Sub

Sub Открыть_урок()
    Dim MyPath As String
    Dim SaveDriveDir As String
    SaveDriveDir = CurDir
    MyPath = "C:\"
    ChDrive MyPath
    ChDir MyPath
    On Error Resume Next
    FOpen = Application.GetOpenFilename(FileFilter:="Text Files (*.txt), *.txt")
    If VarType(FOpen) = vbBoolean Then Exit Sub
Application.ScreenUpdating = False
    Range("G49").Select
    Set ImpRng = ActiveCell
    Open FOpen For Input As #1
    Dim s As String
    Input #1, s
    'If s = "XX#1#2#3#4#5#6#7#8#9#10#11#12#13#14#15#16" Then
    Range("G49").Value = s
    r = 1
    Do Until EOF(1)
        Line Input #1, data
        ActiveCell.Offset(r, 0) = data
        r = r + 1
    Loop
    Close #1
Application.ScreenUpdating = True
    'Else: MsgBox "Файл не прошел проверку ключа!    " & vbNewLine & "Выберите другой файл", vbInformation, "Ошибка в данных"
    'Exit Sub
'End If
End Sub

Range ("B1:P21")

Private Sub CommandButton2_Click()
   Open "C:\MIDI\dadra_i.txt" For Output As #1
        Range("B1:P21").Copy
        With New DataObject
             .GetFromClipboard
             Print #1, Replace(.GetText(1), vbTab, "&")
        End With
        Application.CutCopyMode = False
   Close #1
End Sub

Shell "cmd.exe /t:0f /k cd C:\MIDI" & vbCr