Private Sub Worksheet_Change(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count = 1 Then
        If Not Intersect(Target, Range("B1:B5")) Is Nothing Then
            If Target <> Empty Then
                Dim lr As Long, cell As Range, sh As Worksheet
                Dim ValidFormula As String
                ValidFormula = "=Номера"
                Set sh = Worksheets("Лист2")
                Set cell = sh.Cells.Find(Target)
                Application.EnableEvents = False
                cell.Delete Shift:=xlUp
                If sh.Cells(2, 3) = "" Then
                sh.Cells(2, 3) = Target
                Else
                lr = sh.Cells(Rows.Count, 3).End(xlUp).Row - 1
                sh.Cells(lr, 3).ListObject.ListRows.Add AlwaysInsert:=True
                sh.Cells(lr + 1, 3).Value = Target
                End If
                Application.EnableEvents = True
                With Range("B1:B5").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=ValidFormula
                    .IgnoreBlank = True
                    .InCellDropdown = True
                    .InputTitle = ""
                    .ErrorTitle = ""
                    .InputMessage = ""
                    .ErrorMessage = ""
                    .ShowInput = True
                    .ShowError = True
                End With
            End If
        End If
 End If
End Sub

=МАКС(ПРАВСИМВ([Книга4]Лист1:Лист3!$A$1:$A$10;3))

Function AWB(Префикс_авиакомпании As Variant, Порядковый_номер As Variant) As String
    Dim l As Long
    Dim k As Long
    k = CDbl(Порядковый_номер) + Application.Caller.Row - 2
    l = k - Int(k / 7) * 7
    AWB = Префикс_авиакомпании & "-" & k & l
End Function

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Range("A1")
.FormulaR1C1 = "=""составляет 7 500,00 ("""
.Formula = .Value
Dim m As Variant
Dim n As Variant
m = .Value
For Each n In Array(" ") 'Я изменил эту строку на For Each n In Array("составляет","("), но почему то форматирует некорректно.
    m = Replace(m, n, Chr(160))
Next
a = Split(m, Chr(160))
b = 0
        For i = 0 To UBound(a)
            Select Case i
            Case 1
                With .Characters(b + 1, Len(a(i))).Font
                    .Italic = True
                    .Underline = True
                End With
            End Select
            b = b + Len(a(i)) + 1
        Next
   End With
End Sub

=СМЕЩ(Лист2!$B$2:$B$1048576;0;0;СЧЁТЗ(Лист2!$B$2:$B$1048576))