Code:
Sub Solution3_2Workbooks() '
Rem 1 Worksheets info
Dim WbM As Workbook, WbData As Workbook
Set WbM = ThisWorkbook: Set WbData = Workbooks("Example.xlsx")
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = WbData.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 WbData.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 DropItIn3(WbData.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 WbData.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 DropItIn3(WbData.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
' Call ' Worksheet,data row count, First data row, First break in data, data rows, extra rows to be inserted
'Worksheets("consultant doctor"), UBound(strRws(), 1) + 1 , 8 , 34 27, 7
' 88 , 8 , 34 , 27 , 7
Sub DropItIn3(Ws As Worksheet, RwsCnt As Long, SttRw As Long, FstBkRw As Long, DtaRws As Long, ExtRws As Long) ' https://eileenslounge.com/viewtopic.php?p=271047&sid=d23ea475322d2edf06b70bfeaa95726b#p271047
' Header
ThisWorkbook.Worksheets("TempSht").Range("A7:X7").Copy
Ws.Range("A" & SttRw - 1 & ":X" & SttRw - 1 & "").PasteSpecial Paste:=xlPasteFormats ' https://docs.microsoft.com/en-us/office/vba/api/excel.range.pastespecial https://docs.microsoft.com/de-de/office/vba/api/excel.xlpastetype
' Insert extra rows
' Worksheets("TempSht").Range("A35:X41").Copy
Dim Cnt As Long
' For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) - (DtaRws + ExtRws) Step DtaRws + ExtRws ' This misses the last section
For Cnt = FstBkRw To ((((Int(RwsCnt / DtaRws) + 1) * DtaRws) + (((Int(RwsCnt / DtaRws) + 1) - 1) * ExtRws) + (SttRw - 1))) Step DtaRws + ExtRws
ThisWorkbook.Worksheets("TempSht").Range("A35:X41").Copy
Ws.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Insert shift:=xlShiftDown ' Value = Worksheets("TempSht").Range("A35:X41").Formula
' Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 0).Resize(7, 24).Sort key1:=Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-26, 2), Header:=False ' sorting here will clear the clipboard
Next Cnt
End Sub
Bookmarks