Sub Main()
    Dim rCell As Range, lr&
    'по условию можем вызвать вставку столбца
    If Application.Caller = "Number 1" Then Call InsertColumn(SetRng)
    
    lr = CLng(Right(Application.Caller, 2)) + 7
    Set rCell = Intersect(Results.Rows(lr), SetRng.EntireColumn)
    Select Case lr - 7 'номер фигуры вызвавшей макрос
        Case 1
            'операции с rCell при нажатии на прямоугольник №1
        Case 2
            
        Case 3 To 5
            
        'Case n
    End Select
End Sub

Private Function SetRng() As Range
    Dim rng As Range, rng1 As Range
    With Results
        'ищем дату
        Set rng = .Cells.Find(test.[c2], .[a1])
        If Not rng Is Nothing Then
            'если нашли, ищем весь диапазон дат
            Set rng1 = .Range(rng, rng.End(xlToRight)).Find(rng, rng, , , , xlPrevious)
            Set rng1 = Intersect(.Range(rng, rng1).EntireColumn, .Rows(1))
            'в пересечении диапазона дат и строки ".Rows(1)" с № маршрутов, ищем маршрут
            Set rng = Nothing
            Set rng = rng1.Find(test.[c9], rng1(rng1.Count))
            Dim str$, li%: str = test.[c9]: li = CInt(Left(str, 1))
            Do While rng Is Nothing
                If li = 1 Then Exit Do
                li = li - 1: str = li & Right(str, 5)
                Set rng = rng1.Find(str, rng1(rng1.Count))
            Loop
            If rng Is Nothing Then Set rng = rng1(rng1.Count).Offset(, 1)
        Else
            Set rng = .[d1]
        End If
    End With
    Set SetRng = rng
End Function

Private Sub InsertColumn(ByVal rng As Range)
    rng.EntireColumn.Insert xlRight, xlFormatFromLeftOrAbove
    With rng.Offset(, -1).EntireColumn
        .Interior.Color = xlNone
        'Ваши форматы и значения
        .Cells(7) = test.[c2]                    '.[d7]
        .Cells(3).Resize(5).HorizontalAlignment = xlCenterAcrossSelection    '.[d3:d7]
        .Cells(1).Resize(24).Borders.Weight = xlMedium                       '.[d1].Resize(24)
        .Cells(8).Resize(17).Interior.Color = RGB(120, 7, 7)                 '.Range("D8:D24")
        .Cells(4) = test.[a6]                    '.[d4]
        .Cells(5) = test.[a4]                    '.[d5]
        .Cells(6) = "Фактический результат"                    '.[d6]
        .Cells(1) = test.[c9]                    '.[d1]
        .Cells(2) = test.[a10]                    '.[d2]
        .ColumnWidth = 32                    '.[d5].ColumnWidth
    End With
End Sub

Dim rCell As Range
        With Results
            If .Cells.Find(test.[c2]) Is Nothing Then
            ' тут вставка столбца обычного если нету даты такой ( дата и время )
            End If
                If Me.Label1.Caption = Results.Range("b8").Value And Me.Label2.Caption = Results.Range("c8").Value Then
                    Set rCell = Intersect(.Rows(8), .Cells.Find(test.[c2]).EntireColumn)                    ' как тут должно быть прописано?
                ElseIf Me.Label1.Caption = Results.Range("b10").Value And Me.Label2.Caption = Results.Range("c10").Value Then
                    Set rCell = Intersect(.Rows(10), .Cells.Find(test.[c2]).EntireColumn)
                End If
                    If IsEmpty(rCell) = False Then
                        With Results
                          'Тут вставка абсолютно такого же столбца но если не пусто
                    If Me.Label1.Caption = Results.Range("b8").Value And Me.Label2.Caption = Results.Range("c8").Value Then              
                    Set rCell = Intersect(.Rows(8), .Cells.Find(test.[c2]).EntireColumn)
                    ElseIf Me.Label1.Caption = Results.Range("b10").Value And Me.Label2.Caption = Results.Range("c10").Value Then
                    Set rCell = Intersect(.Rows(10), .Cells.Find(test.[c2]).EntireColumn)
                    End If
                        End With
                    End If
                    With rCell
                    rCell.WrapText = True
                    .Value = "Ошибок нет"
                    .Interior.Color = vbGreen
                    End With
                    With Results
                    If .[d8].Interior.Color = vbGreen And .[d10].Interior.Color = vbGreen Then             
                    .[d3].Value = "Выполнено без ошибок"
                    .[d3].Interior.Color = vbGreen
                    ElseIf .[d7].Interior.Color = vbYellow Or .[d10].Interior.Color = vbYellow Then
                    .[d3].Value = "Есть ошибки"
                    .[d3].Interior.Color = vbYellow
                    End If
                    End With
                    If Me.Label1.Caption = Results.Range("b8").Value And Me.Label2.Caption = Results.Range("c8").Value Then       'Это у меня такое перелистывание на следующую строку
                    Me.Label1.Caption = Results.Range("b10").Value
                    Me.Label2.Caption = Results.Range("c10").Value
                    ElseIf Me.Label1.Caption = Results.Range("b10").Value And Me.Label2.Caption = Results.Range("c10").Value Then
                    MsgBox ("Вы завершили первый маршрут из шести ''^_^''")
                    Unload OneSix
                    whoForm.Show
                    End If
        End With

Private Sub UserForm_Initialize()
    'Me.Label1.Caption = Workbooks("Resultati.xlsm").Worksheets("Основные").Range("b7").Value
    '    Me.Label2.Caption = Workbooks("Resultati.xlsm").Worksheets("Основные").Range("c7").Value
    'Me.Frame1.Caption = Workbooks("Resultati.xlsm").Worksheets("Основные").Name
    
    Dim rng As Range
    With Results
        'ищем дату без времени
        Set rng = .Cells.Find(Format(test.[c2], "dd.mm.yyyy"), .[a1], , xlPart)
        If Not rng Is Nothing Then
            'если строка последней заполненной ячейки в столбце D, не совпадает с последней
            'заполненной строкой в столбце B
            If .Cells(.Rows.Count, "D").End(xlUp).Row <> .Cells(.Rows.Count, "B").End(xlUp).Row Then
                'продолжаем тест со следующего этапа
                With .Cells(.Rows.Count, "D").End(xlUp).Offset(1)  'следующая строка
                    Me.Label1.Caption = .Offset(, -2)   'столбец B
                    Me.Label2.Caption = .Offset(, -1)   'столбец C
                End With
            Else
                'в противном случае вставляем новый столбец
                Call InsertColumnD
                'тест с 1 этапа
                Me.Label1.Caption = .[b7]: Me.Label2.Caption = .[c7]
            End If
        Else
            'если нет даты
            Call InsertColumnD
            Me.Label1.Caption = .[b7]: Me.Label2.Caption = .[c7]
        End If
        
        Me.Frame1.Caption = .Name
    End With
    
End Sub

Private Sub CommandButton1_Click()
    Dim rCell As Range
    
    With Results
        'поиск целевой ячейки сводится к поиску последней строки в столбце "D"
        Set rCell = .Cells(.Rows.Count, "D").End(xlUp).Offset(1)
        With rCell
            .WrapText = True
            .Value = "Ошибок нет"
            .Interior.Color = vbGreen
        End With
        
        'если последний этап
        If rCell.Row = .Cells(.Rows.Count, "B").End(xlUp).Row Then
            .[d2].Value = "Ошибок нет"
            .[d2].Interior.Color = vbGreen
            For Each rCell In .Range("d7:d11")
                If Not rCell.Interior.Color = vbGreen Then
                    .[d2].Value = "Есть ошибки"
                    .[d2].Interior.Color = vbYellow
                    Exit For
                End If
            Next rCell
            MsgBox ("Вы завершили все этапы этапы сценариев по группе ''Основные''")
            Unload MFOForm
        Else
            With rCell.Offset(1)    'следующая строка
                Me.Label1.Caption = .Offset(, -2)   'столбец B
                Me.Label2.Caption = .Offset(, -1)   'столбец C
            End With
        End If
    End With
End Sub