Solution for this post:
https://eileenslounge.com/viewtopic....271047#p271047
https://eileenslounge.com/viewtopic....271137#p271137

The main thing is
Sub DropItIn()

The first macro, Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() , which is the one that you run, is almost identical to the very first unmodified macro, Sub VBAArrayTypeAlternativeToFilter() ' https://eileenslounge.com/viewtopic....270792#p270792



Code:
Sub VBAArrayTypeAlternativeToFilterToSegs_Solution2() '               https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = Worksheets("Main workbook").Range("K1:K" & Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
         Let strSuc = strSuc & " " & Cnt
        Else
         Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
' First output worksheet
Dim clms() As Variant: Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim arrOut() As Variant: Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
    With Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
    Let .Value = arrOut()
    .Sort Key1:=Worksheets("consultant doctor").Range("C7"), Header:=True
    .Font.Name = "Times New Roman"
    .Font.Size = 13
    .Columns("D:X").NumberFormat = "0.00"
    .EntireColumn.AutoFit
    .Borders.LineStyle = xlContinuous
    End With
' Adding extra rows and stuff for  Worksheets("consultant doctor") ================
'        Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
 Call DropItIn(Worksheets("consultant doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7)                                            '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
' second output worksheet
'Let clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
 ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
     Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
 Let arrOut() = Application.Index(Worksheets("Main workbook").Cells, Rws(), clms())
    With Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2))
     Let .Value = arrOut()
     .Sort Key1:=Worksheets("Specialist Doctor").Range("C7"), Header:=True
     .Font.Name = "Times New Roman"
     .Font.Size = 13
     .Columns("D:X").NumberFormat = "0.00"
     .EntireColumn.AutoFit
     .Borders.LineStyle = xlContinuous
    End With
' Adding extra rows and stuff for  Worksheets("Specialist Doctor") ==================
'        Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
 Call DropItIn(Worksheets("Specialist Doctor"), UBound(strRws(), 1) + 1, 8, 34, 27, 7)                                            '  Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted

End Sub