Sub QWE()
Dim dic, cell As Range, arr, k&
        Set dic = CreateObject("scripting.dictionary")
        For Each cell In [города]
            dic.Add [список].Find(cell).Row, cell.Value
        Next
        arr = dic.keys
        For k = 1 To UBound(arr)
            Me.HPageBreaks.Add before:=Range("список")(arr(k))
        Next
        Set dic = Nothing
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
     Dim cell As Range, cell2 As Range
     Application.ScreenUpdating = False
     If Not Sh Is Sheets(1) Then
         For Each cell In Sh.[B5:B30]
             Set cell2 = Sheets(1).Range(cell.Address)
             cell.Interior.ColorIndex = cell2.Interior.ColorIndex
         Next
     End If
     Application.ScreenUpdating = True
End Sub

=СУММ(1/СЧЁТЕСЛИМН($A$6:$A$25;$A$6:$A$25;$B$6:$B$25;$B$6:$B$25))

=СУММ(1/СЧЁТЕСЛИМН($A$6:$A$25;$A$6:$A$25;$C$6:$C$25;$C$6:$C$25))

=СУММПРОИЗВ(СЧЁТЕСЛИМН($A$6:$A$25;$A$6:$A$25;$B$6:$B$25;$B$6:$B$25)^(2*(($A$6:$A$25=0)+($B$6:$B$25=0))-1))

=СУММПРОИЗВ(СЧЁТЕСЛИМН($A$6:$A$25;$A$6:$A$25;$C$6:$C$25;$C$6:$C$25)^(2*(($A$6:$A$25=0)+($C$6:$C$25=0))-1))

Sub sdf()
       Dim cell As Range, arr As Variant
       If Selection.Columns.Count > 1 Then Exit Sub
       With Application: .ScreenUpdating = 0: .EnableEvents = 0
           With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
               For Each cell In Selection
                   arr = Split(cell, ", ")
                   If UBound(arr) * Len(cell) Then
                       cell.EntireRow.Offset(1).Resize(UBound(arr)).Insert
                       cell.EntireRow.Copy cell.EntireRow.Offset(1).Resize(UBound(arr))
                       .SetText Replace(Trim(cell), ", ", Chr(10)): .PutInClipboard
                       cell.PasteSpecial xlPasteAll
                   End If
                   Next
           End With
       .ScreenUpdating = 1: .EnableEvents = 1: End With
End Sub

Private Type POINTAPI
         x As Long
         y As Long
End Type
Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Sub clickpos()
     Dim i%, curpos As POINTAPI
     Do
         If GetAsyncKeyState(1) And &H8000 Then
             GetCursorPos curpos
             [A1].Offset(i) = curpos.x
             [A1].Offset(i, 1) = curpos.y
             i = i + 1
             Do
                 DoEvents
             Loop While GetAsyncKeyState(1) And &H8000
         End If
         DoEvents
     Loop Until i = 3
End Sub

Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Sub sss()
     Dim h As Long
     h = FindWindowEx(GetDesktopWindow, 0, "Button", "Start")
     If h <> 0 Then
         SendMessage h, &HF5, 0, 0
         SendMessage h, &H202, 0, 0
     End If
End Sub

Public Function ФИО$(S)
Dim Sout As String
Sout = S
     Set RegExp = CreateObject("VBScript.RegExp")
     RegExp.Global = True
     RegExp.Pattern = "([\s\S]*)([а-я])([А-Я])([\s\S]*)"
     Do
         If RegExp.test(Sout) Then
             Sout = RegExp.Replace(Sout, "$1$2 $3$4")
         End If
     Loop While RegExp.test(Sout)
    ФИО = Trim(Sout)
End Function

Function getFIO$(str$)
     Dim S$: S = Trim(str)
     With CreateObject("VBScript.RegExp")
         .IgnoreCase = False
         .Global = True
         .Pattern = "([.-]) +"
         Do
             If .Test(S) Then S = .Replace(S, "$1")
         Loop While .Test(S)
         .Pattern = "[\s\S]*?([А-Яа-яЁё]+ [А-ЯЁ.-]{4,7})[\s\S]*"
         If .Test(S) Then getFIO = .Replace(S, "$1")
     End With
End Function