Sub folder()
On Error Resume Next
For Each oCell In Range([A1], [A65536].End(xlUp))
    If Not IsEmpty(oCell) Then 
          MkDir "C:\Users\Роман\Desktop\шаблон\" & oCell
          ActiveWorkbook.SaveCopyAs filename:=ThisWorkbook.Path & "\" & [A1].Value & ".xls"
End if
Next
End Sub

Range("A20:AI20").Select
   Selection.Clear

Range("A20:AI20").Clear

Range("R90:R94").Replace What:=" (", Replacement:=";", LookAt:=xlPart, _
       SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
       ReplaceFormat:=False

If ДанныеМарка = ПланМарка Then
    If  ДанныеТонн - Точность <= ПланТонн And ДанныеТонн + Точность >= ПланТонн Then
         If  ДанныеВремяГода = ПланВремяГода Then
            If  ДанныеВремя = ПланВремя Then
            '  code 1
            end if
         '  code 2
         end if
     '  code 3
     end if
 '  code 4
 end if

Private Sub Worksheet_SelectionChange(ByVal Target As Range) With Range("A8")
    .Value = "за период с " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 1, "[$-FC22]« D » MMMM 20 YY г.") & " по " & Format(DateSerial(Year(Now), Month(Now) + 0, 0) + 10, "[$-FC22]« D » MMMM 20 YY г.")
    a = Split(.Value, " ")
        For i = 0 To UBound(a)
            Select Case i
            Case 4, 6, 8, 12, 14, 16
                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
With Range("A19")
.FormulaR1C1 = "=""1.1. Обязательство Субагента перед Агентом по перечислению выручки," _
& " полученной от реализации перевозок по договору №13 – САГ от « 28 » августа 20 20 года," _
& " составляет""&"" ""&'[Реестр грузовых авианакладных копия1.xlsm]Итоговая декада'!R13C15&"" ""&'[Реестр грузовых авианакладных копия1.xlsm]Итоговая декада'!R14C15&"",""&"" без НДС."""
.Formula = .Value
a = Split(.Value, " ")
b=0                                             ' Вот тут
        For i = 0 To UBound(a)
            Select Case i
            Case 0
                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