Dim c As Objectt

Sub Korekt()
With CreateObject("VBScript.RegExp")
    .Pattern = "\ .+\ "
     For Each c In Range("B4:B9")
    c.Value = .Replace(c.Value, "")
   Next
  End With
End Sub

Sub Schedule()  ' Расписание'
  
    Dim t, p, m, a      As Variant
    Dim r, c, rw, s, i  As Long
    
    
    m = Raspis.Range("D1")
    p = Raspis.Range("D2")
    If IsEmpty(m) Or IsEmpty(p) Then Exit Sub
  
    t = Base.[D1].CurrentRegion
    Raspis.Range("B5:F29").ClearContents
  
    For r = 2 To UBound(t)
     
      If t(r, 1) = m And t(r, 2) = p Then
       
       If t(r, 5) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2
        
        If t(r, 5) Like "Три*" Then c = 1
         
         rw = Round((t(r, 4) - 1 / 3) * 48, 0) + 5 ' Вот это точно КОД Да Винчи  
        
        a = Cells(rw, 2).Resize(1, 5)
       
       For i = c To 5 Step s: a(1, i) = t(r, 3): Next
      
      Cells(rw, 2).Resize(1, 5) = a
    
    End If
  
  Next

End Sub

Sub Posech_Form_Initialize()  
    
    Dim var1    As Variant
    Dim var2    As Variant
    Dim var3    As Variant
    Dim i       As Long

    Set ShBase = ThisWorkbook.Worksheets("БД")
    Set BaseListObj = ShBase.ListObjects("База_tb")

    var1 = BaseListObj.ListColumns("Месяц").Range
    var = var1
    var2 = BaseListObj.ListColumns("Специалист").Range.Value
    var3 = BaseListObj.ListColumns("ФИО").Range.Value

    For i = LBound(var) To UBound(var)
        var(i, 1) = var1(i, 1) & var2(i, 1) & var3(i, 1)
    Next i

    Set rngProp = BaseListObj.ListColumns("Количество посещённых занятий").Range
    Set rngNeed = BaseListObj.ListColumns("Количество нужных занятий").Range

End Sub

Sub Schedule()
  Dim t, r&, rw&, m, p, a, c&, s&, i&
  m = [d1]: p = [d2]: If IsEmpty(m) Or IsEmpty(p) Then Exit Sub
  t = [L1].CurrentRegion: [b5:f29].ClearContents
  For r = 2 To UBound(t)
    If t(r, 1) = m And t(r, 2) = p Then
      If t(r, 5) Like "Полная*" Then c = 1: s = 1 Else c = 2: s = 2
      If t(r, 5) Like "Три*" Then c = 1
      rw = Round((t(r, 4) - 1 / 3) * 48, 0) + 5
      a = Cells(rw, 2).Resize(1, 5)
      For i = c To 5 Step s: a(1, i) = t(r, 3): Next
      Cells(rw, 2).Resize(1, 5) = a
    End If
  Next
End Sub