Dim x As Control, lr&, iStr$
lr = .Cells(1, 1).End(xlUp).Row + 1
For Each x In Me.Controls
    If TypeOf x Is MSForms.CheckBox Then
        If x = True Then
            .Cells(lr, 1).Value = frmKust1.Value
            .Cells(lr, 3) = rcNow1.Value
            .Cells(lr, 4).Value = rcTo1.Value
            'вместо 'Первый Второй и т.п.' впишите ИМЕНА своих чекбоксов
            Select Case x.Name
                Case "Первый": iStr = "S"
                Case "Второй": iStr = "F"
                Case "Третий": iStr = "A"
                Case "Четвертый": iStr = "FV"
                Case "Пятый": iStr = "Fr"
            End Select
            Cells(lr, 2) = iStr
            lr = lr + 1
        End If
    End If
Next

=ИНДЕКС('Лист 2'!$A$2:$F$6;ПОИСКПОЗ(B2;'Лист 2'!$E$2:$E$6;0);1)

Function GetCBText()
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    .GetFromClipboard
    GetCBText = .GetText
End With
End Function

Sub Вставка_формулы_в_область()
Dim iCl As Range, iRow&
With ActiveSheet
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set iCl = .UsedRange.Find("столб")
    If Not iCl Is Nothing Then
        With iCl.Offset(1).Resize(lRow - iCl.Row)
            .FormulaR1C1 = "=RC[-2]+RC[-1]"
            .Value = .Value
        End With
    Else
        MsgBox "Столбец 'столб' не найден!", vbCritical
        Exit Sub
    End If
End With
End Sub

Sub Вставка_формулы_в_область()
Dim iCl As Range, iRow&
With ActiveSheet
    lRow = .Cells(.Rows.Count, 1).End(xlUp).Row
    Set iCl = .UsedRange.Find("столб")
    If Not iCl Is Nothing Then
        iCl.Offset(1).Resize(lRow - iCl.Row).FormulaR1C1 = "=RC[-2]+RC[-1]"
    Else
        MsgBox "Столбец 'столб' не найден!", vbCritical
        Exit Sub
    End If
End With
End Sub

Cells(G, 1).Value = Mid(Cells(G, 1).Value, 1, Len(Cells(G, 1).Value) - 16)

Cells(G, 1) = Mid(Cells(G, 1), 1, Len(Cells(G, 1)) - 16)

Function СЧЁТУНИКЕСЛИ(rng1 As Range, rng2 As Range, kr As Variant) As Double
arr1 = Intersect(rng1, rng1.Parent.UsedRange).Value
arr2 = Intersect(rng2, rng2.Parent.UsedRange).Value
СЧЁТУНИКЕСЛИ = 0
With CreateObject("Scripting.Dictionary")
    For I = LBound(arr2) To UBound(arr2)
        If IsDate(arr2(I, 1)) Then
            If arr2(I, 1) <= CDate(kr) Then
                If Not .Exists(arr1(I, 1)) Then СЧЁТУНИКЕСЛИ = СЧЁТУНИКЕСЛИ + 1
            End If
        End If
    Next
End With
End Function