Code:
' 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
' I need my array to be like 137 rather than like 109 strRws() is 0 To 108 ,
' 137 is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1
' Missing is ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it
Dim LstEmptyRws As Long: Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
Let strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this & " 4" so don't habe a last space to remove
Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' Stop
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 RwsT() As Variant, ClmsT() As Variant
Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 2 3 4 5 6 .....
Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")") ' "vertical" 1 1 1 1 1 1 1 .....
Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT())
Dim arrOut() As Variant ' This is the main output, all in one go. But we can put some values into the array before...
Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms())
' ... we can put some values (words) and formulas into the array before we paste it out
For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34 ' ... we can put some values into the array before...
Let arrOut(Cnt + 1 - 6, 1) = "The total" ' -6 is because we have top right of A7
Let arrOut(Cnt + 7 - 6, 1) = "Previous total"
Dim Cl As Long ' formulas
For Cl = 4 To 24 ' D To X
Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Let arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
Next Cl
' 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", "", "")
Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Let arrOut(Cnt + 2 - 6, 7) = "Second signature"
Let arrOut(Cnt + 2 - 6, 12) = "Third signature"
Let arrOut(Cnt + 2 - 6, 17) = "Forth signature"
Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
' Let arrOut(Cnt + 2 - 6, 2) = "First signature"
Next Cnt
' Main paste out of all data and some words and formulas
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
' delete last unwanted Previous Total row
ThisWorkbook.Worksheets("consultant doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp ' http://www.eileenslounge.com/viewtopic.php?p=271328#p271328 ....Go back to my first post, and look at my maths logic. In the macro we have ((Segs * 27) + ((Segs - 1) * 7) + 7) This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102 I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...."
' End first stage worksheet___________________________________________________________________________________________
'
Reply With Quote
Bookmarks