Code:
Sub Solution8() ' http://www.eileenslounge.com/viewtopic.php?p=271368#p271368 similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.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
'Debug.Print strSuc
' First half ##
' First stage 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)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop===============================================================
' we must now re make strsuc
Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
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(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
'Second half worksheet Consultant doctor
ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("consultant doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("consultant doctor")
Next Cnt
' First half##
' Second stage output worksheet Specialist Doctor
'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(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
For rOuter = 2 To UBound(strNms)
' Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
If strNms(rOuter) > strNms(rInner) Then
' Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
' Dim TempRs As String
Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0 not 1
Else
End If
Next rInner ' -----------------------------------------------------------------------
Next rOuter ' ==================End Outer Loop===============================================================
' we must now re make strsuc
Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1 to give us the number of row indicies
'Dim Segs As Long
Let Segs = Int(TotRws / 27) + 1
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Next Cnt
Let strRws() = Split(strSpit, " ", -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(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
'Second half worksheet Specialist Doctor
ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
.Font.Name = "Times New Roman"
.Font.Size = 13
.Columns("D:X").NumberFormat = "0.00"
.EntireColumn.AutoFit
End With
'
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
With ThisWorkbook.Worksheets("Specialist Doctor")
' Most borders
.Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
' Sum formulas
.Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
.Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' First signature Second signature third signature Fourth signature Fifth signature
.Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
' Bold stuff
.Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
'
.Range("A" & Cnt + 1 & "").Value = "The total"
.Range("A" & Cnt + 7 & "").Value = "Previous total"
' row height for "Total" and "previous total"
.Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
.Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50 '
' HPageBreaks.Add
.HPageBreaks.Add .Range("A" & Cnt + 7 & "")
End With ' ThisWorkbook.Worksheets("Specialist Doctor")
Next Cnt
End Sub
Reply With Quote
Originally Posted by vba_php
Bookmarks