Tests Copying, Pasting, API Cliipboard issues. and Rough notes on Advanced API stuff

**DocAElstein** · 07-15-2020, 01:54 PM

Macro for last post, and also for anser to this Thread post:
https://excelfox.com/forum/showthrea...ll=1#post14578
https://excelfox.com/forum/showthrea...ll=1#post14591
https://www.excelforum.com/excel-pro...n-matches.html
https://excelfox.com/forum/showthrea...ll=1#post14588
https://eileenslounge.com/viewtopic.php?f=30&t=34936

Code:

'     https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578  https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
'  https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
Sub STEP6()
Dim Ws1 As Worksheet, Ws2 As Worksheet
Dim Wb1 As Workbook, Wb2 As Workbook
Dim R2 As Long, Lr As Long, I As Long ' r2&, lr&, i&

Set Wb1 = Workbooks("1.xls") ' For open workbook              Alternatively to open worknok - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") '  Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Wb2 = Workbooks("AlertCodes.xlsx")                                                                ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xlsx")
Set Ws2 = Wb2.Worksheets.Item(4)
    With Ws1
     Let Lr = .Cells(.Rows.Count, "A").End(xlUp).Row
        For I = 2 To Lr
        ' Reset r2
        R2 = 0
        ' Avoid error messages
        On Error Resume Next
        ' Try to get r2
        R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0)  '  R2 returns the  matched row  if there is a match
        ' Restore error handling
        On Error GoTo 0
        ' Only set column K if r2 is valid
            If R2 > 0 Then
                If Ws2.Cells(R2, "D") = ">" Then
                 .Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value   '   Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value
                Else
                 .Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value   '   Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
                End If
           End If
        Next I
    End With
Wb1.Save
Wb1.Close
Wb2.Close

End Sub

**DocAElstein** · 07-16-2020, 12:18 PM

test post to get URL for later use

**DocAElstein** · 07-16-2020, 01:48 PM

Alternative solution to Step6()
( https://excelfox.com/forum/showthrea...ll=1#post14594 )

The main changes are
_1) I use arrays. ( arr1() , arr2() , arr2B() )
I do this just from personal choice. I do this because arrays work much faster if you are only interested in values with no cell formatting
_2) I changed WorksheetFunction.Match to Application.Match , because I do not like to use On Error Resume Next
I do not need On Error Resume Next for Application.Match , because , if it does not find a match, it does not error. Instead, it returns a VBA error string message, which can be tested for using IsError( __ )
_2) I do not use _ With _ End With _ because it confuses me

I left the original code lines in , ' commented out for comparison

Code:

' https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342720    https://www.excelforum.com/excel-programming-vba-macros/1318061-conditionally-calculate-the-data-and-paste-it-if-condition-matches.html#post5342598
'     https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks/page4#post14578  https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14578&viewfull=1#post14578
'  https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14591&viewfull=1#post14591
Sub STEP6Alternative()
Rem 1 Worksheets data info
Dim Wb1 As Workbook, Wb2 As Workbook, Ws1 As Worksheet, Ws2 As Worksheet
Dim I As Long, Lr As Long   '       R2 As Long, Lr As Long, I As Long ' r2&, lr&, i&
Set Wb1 = Workbooks("1.xls") ' For open workbook              Alternatively to open workbook - Examples: Workbooks.Open(ThisWorkbook.Path & "\1.xls") '  Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\1.xls")
Set Ws1 = Wb1.Worksheets.Item(1)
Set Wb2 = Workbooks("AlertCodes.xlsx")                                                                 ' Workbooks.Open(ThisWorkbook.Path & "\AlertCodes.xlsx") ' Workbooks.Open("C:\Users\WolfieeeStyle\Desktop\Files\AlertCodes.xlsx")
Set Ws2 = Wb2.Worksheets.Item(4)
'    With Ws1
 Let Lr = Ws1.Cells(Ws1.Rows.Count, "A").End(xlUp).Row
Dim arr1() As Variant
Let arr1() = Ws1.Range("A1:K" & Lr & "").Value2
Dim lr2 As Long '    https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=14565&viewfull=1#post14565   Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
 Let lr2 = Ws2.Cells(Ws2.Rows.Count, "B").End(xlUp).Row          ' This is the column to be serached in
Dim arr2B() As Variant
 Let arr2B() = Ws2.Range("B1:B" & lr2 & "").Value2
Dim arr2() As Variant
 Let arr2() = Ws2.Range("A1:K" & lr2 & "").Value2
Rem We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2.
    For I = 2 To Lr ' We consider the data values in column I of 1.xls ( first worksheet) , starting from row 2.
                                                                 ' Reset r2 R2 = 0   ' Avoid error messages  On Error Resume Next
    ' Try to get r2       Values in column I of 1.xls ( first worksheet), starting at row 2, are to be looked for, ( Matched ) in column B of AlertCodes.xlsx ( 4th worksheet )
    'R2 = WorksheetFunction.Match(.Cells(I, "I"), Ws2.[B:B], 0)  '  R2 returns the  matched row  if there is a match
    Dim R2 As Variant  ' We need a variant so that  both a  Long Number   or a  VB error  can be held in it, which are the two possible return types with Application.Match  https://excelfox.com/forum/showthread.php/2349-Copy-and-Paste-based-on-comparisons-Match-and-calculations-of-cells-in-two-workbooks?p=14204&viewfull=1#post14204
     Let R2 = Application.Match(arr1(I, 9), arr2B(), 0)    ' Ws1.Cells(I, "I").Value  is  arr1(I, 9)                                                          ' Restore error handling     On Error GoTo 0
    ' Only set column K if r2 is valid, so only if a match was found, so only if R" is  Not  a  VBA error
        If Not IsError(R2) Then '                    If R2 > 0 Then
            'If Ws2.Cells(R2, "D") = ">" Then   '    Ws2.Cells(R2, "D").Value  is  arr2(R2, 4)
            If arr2(R2, 4) = ">" Then
            ' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value - 0.01 * Ws2.Cells(R2, "E").Value   '                                     This was wrong:  Ws2.Cells(I, "E").Value - 0.01 * Ws2.Cells(I, "E").Value
                          arr1(I, 11) = arr2(R2, 5) - 0.01 * arr2(R2, 5)
            'Else
            ElseIf arr2(R2, 4) = "<" Then
            ' Ws1.Cells(I, "K").Value = Ws2.Cells(R2, "E").Value + 0.01 * Ws2.Cells(R2, "E").Value   '                                     This was wrong:  Ws2.Cells(I, "E").Value + 0.01 * Ws2.Cells(I, "E").Value
                          arr1(I, 11) = arr2(R2, 5) + 0.01 * arr2(R2, 5)
            Else
             ' we dont have a "<" or a ">"  Do Nothing
            End If
       End If
    Next I
'   End With
'Rem Option to save and/ or close files
Wb1.Save
Wb1.Close
Wb2.Close
End Sub

**DocAElstein** · 07-24-2020, 01:59 PM

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub Ha2a()  '  https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) '  First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row      '    Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2 ' The only data needed to ba considered is column A.  The "magic code line" will be used to get all our results in one go  I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop  Do ing  While  data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
    Do ' ========================================================== Main Outel loop for unique name section==
    Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
    Dim strRws As String: Let strRws = "1"  ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
        Do
        '3a) get the row indicies for this section
         Let CntIn = CntIn + 1
         Let strRws = strRws & " " & CntIn
        Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
    '3b) start doing stuff for each unique name
    '3b(i) The workbook with unique name
     Workbooks.Add
    Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
    Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
    '3b(ii) The "vertical" array of row indicies required for "magic code line"
    Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
    Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the  ReDim  method below allows us to make the sizing dynamic based on the size of  Rws()
     ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The  +1  comes in because the  Split  function returns a 1D array starting at indicia 0
    Dim Cnt As Long
        For Cnt = 1 To UBound(Rws()) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    '3b(iii) The "magic code line"
    Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)")  ' ** CHANGE TO SUIT ** This is currently for columns A B C  1 2 3  For non consequtive columns you can use like  Array("1", "3", "26")  - that last example gives in the new range just columns A C Z from the original worksheet
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line ---     '  "Magic code line"            http://www.eileenslounge.com/viewtopic.php?p=265384#p265384    http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384          See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172  , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp   for full explanation
    '3b(iv) Output to first worksheet in workbook and close and save it
     Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
     Workbooks(WbNme).Close Savechanges:=True
    '3b(v) Some tidying up before we possibly go to the next unique name
     Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name
    Loop While CntIn < Lr
    ' =======================================================================================================


End Sub
' Simplified version
Sub Ha2a_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
    Do
    Dim strRws As String: Let strRws = "1"
        Do
         Let CntIn = CntIn + 1
         Let strRws = strRws & " " & CntIn
        Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
     Workbooks.Add
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
    Dim Rws() As String: Let Rws() = Split(strRws)
    Dim RwsT() As String
     ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
    Dim Cnt As Long
        For Cnt = 1 To UBound(Rws()) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
     Let Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
     Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
     Let strRws = "1"
    Loop While CntIn < Lr
End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic....245238#p245238

Ref

**DocAElstein** · 07-24-2020, 03:12 PM

Full macro version for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub Ha2b()  '  https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) '  First worksheet counting tabs from the left
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row  '    Make Lr Dynamic : https://excelfox.com/forum/showthread.php/2364-Delete-rows-based-on-match-criteria-in-two-excel-files?p=11467&viewfull=1#post11467
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2 ' The only data needed to ba considered is column A.  The "magic code line" will be used to get all our results in one go  I need +1 to use an empty line in determining when the last name in the list has something different after it ##
Rem 2 Outer loop  Do ing  While  data is still there in column A
Dim CntIn As Long: Let CntIn = 1 ' This will be for counting as We go down rows in column A
Dim strTRw As Long: Let strTRw = 2  ' We are wanting to determine the start and stop row of a grouped names section. The first one will be at row 2
    
    Do ' ========================================================== Main Outel loop for unique name section==
    Rem 3 Inner Loop for a section of names ' ---------------------------------------------------------------
        Do
        '3a) get the row indicies for this section
         Let CntIn = CntIn + 1
        Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1) ' this means we are not yet at the end of a section ---
    '3b) start doing stuff for each unique name
    '3b(i) The workbook with unique name
     Workbooks.Add
    Dim WbNme As String: Let WbNme = arrA(CntIn, 1) & ".xlsx" ' The current last unique name will be the new Workbook name
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
    Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
    '3b(ii) The "vertical" array of row indicies required for "magic code line"
    Dim StpRw As Long: Let StpRw = CntIn ' this is the last row for a group of names
    Dim RwsT() As Variant ' I need Variant  because the   Evaluate(" ")  methond below returns its field of values in housed in  Variant  type elements
     Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
    '3b(iii) The "magic code line"
    Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)")  ' ** CHANGE TO SUIT ** This is currently for columns A B C  1 2 3  For non consequtive columns you can use like  Array("1", "3", "26")  - that last example gives in the new range just columns A C Z from the original worksheet
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line ---     '  "Magic code line"            http://www.eileenslounge.com/viewtopic.php?p=265384#p265384    http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384          See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172  , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp   for full explanation
    '3b(iv) Output to first worksheet in workbook and close and save it
     'Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
     Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' I am missing the Header row so start at top left  A2  to leave space for the Header
     WsM.Range("A1:C1").Copy ' Header row
     Ws.Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
     Workbooks(WbNme).Close Savechanges:=True
    '3b(v) Some tidying up before we possibly go to the next unique name
     Let strTRw = CntIn + 1 ' I assume the next row is  the next name
    Loop While CntIn < LrM
    ' =======================================================================================================


End Sub
' simplified version
Sub Ha2b_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim LrM As Long: Let LrM = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & LrM + 1 & "").Value2
Dim CntIn As Long: Let CntIn = 1
Dim strTRw As Long: Let strTRw = 2
    Do
        Do
         Let CntIn = CntIn + 1
        Loop While arrA(CntIn + 1, 1) = arrA(CntIn, 1)
     Workbooks.Add
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrA(CntIn, 1) & ".xlsx"
    Dim Ws As Worksheet: Set Ws = Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1)
    Dim StpRw As Long: Let StpRw = CntIn
    Dim RwsT() As Variant
     Let RwsT() = Evaluate("=ROW(" & strTRw & ":" & StpRw & ")")
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
     Let Ws.Range("A2").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
     WsM.Range("A1:C1").Copy
     Workbooks(arrA(CntIn, 1) & ".xlsx").Worksheets.Item(1).Range("A1").PasteSpecial Paste:=xlPasteAllUsingSourceTheme
     Workbooks(arrA(CntIn, 1) & ".xlsx").Close Savechanges:=True
     Let strTRw = CntIn + 1
    Loop While CntIn < LrM
End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic....245238#p245238

Ref

**DocAElstein** · 07-24-2020, 04:21 PM

Full macro versions for this Thread
https://eileenslounge.com/viewtopic.php?f=27&t=35006
solution post
https://eileenslounge.com/viewtopic....271960#p271960

Code:

Sub DaDoRunRonDeDo2()  '  https://eileenslounge.com/viewtopic.php?f=27&t=35006
Rem 1 worksheets data info
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1) '  First worksheet counting tabs from the left
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Rem 2 obtain unique values from column A
' 2a) A single string containing the unique names
Dim Cnt As Long
    For Cnt = 2 To Lr Step 1
    Dim strUnics As String
        If InStr(1, strUnics, arrA(Cnt, 1), vbBinaryCompare) = 0 Then
         Let strUnics = strUnics & arrA(Cnt, 1) & " "
        Else
        ' we already had that name in the string
        End If
    Next Cnt
 Let strUnics = Left(strUnics, (Len(strUnics) - 1)) ' Take off last space
' 2b) A 1 dimansional array of the unique names
Dim arrUnics() As String: Let arrUnics() = Split(strUnics, " ", -1, vbBinaryCompare)
Rem 3 Do it for each unique name
Dim WbCnt As Long: Let WbCnt = UBound(arrUnics()) + 1 ' +1 is needed because  Split  function returns an array starting at indicia  0
    For WbCnt = 1 To WbCnt '  Main outer Loop  ========================================
    ' 3a) Get our indicies for the rows wanted of our current name
    Dim strRws As String: Let strRws = "1"  ' We are building a string of our required row indicia for a unique name. The first row , the header, will always be needed
        For Cnt = 2 To Lr Step 1
            If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then
             Let strRws = strRws & " " & Cnt
            Else
            ' The name is not one of the current name being considered
            End If
        Next Cnt
    '3b) start doing stuff for each unique name
    '3b(i) The workbook with unique name
     Workbooks.Add
    Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx" ' The current last unique name will be the new Workbook name
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & WbNme '
    Dim Ws As Worksheet: Set Ws = Workbooks(WbNme).Worksheets.Item(1)
     
     '3b(ii) The "vertical" array of row indicies required for "magic code line"
    Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare) ' I can make a 1 Dimesional pseudo "horizontal" array easilly, from which the "horizontal array, RwsT() can be made
    Dim RwsT() As String ' I must make this a dynamic array, even though I know the dimensions, because the Dim statement will only take hard coded numbers, wheras the  ReDim  method below allows us to make the sizing dynamic based on the size of  Rws()
     ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1) ' The  +1  comes in because the  Split  function returns a 1D array starting at indicia 0
        For Cnt = 1 To UBound(Rws()) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    '3b(iii) The "magic code line"
    Dim Clms() As Variant: Let Clms() = Evaluate("=COLUMN(A:C)")  ' ** CHANGE TO SUIT ** This is currently for columns A B C  1 2 3  For non consequtive columns you can use like  Array("1", "3", "26")  - that last example gives in the new range just columns A C Z from the original worksheet
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Clms()) ' The magic code line ---     '  "Magic code line"            http://www.eileenslounge.com/viewtopic.php?p=265384#p265384    http://www.eileenslounge.com/viewtopic.php?p=265384&sid=39b6d764de41f462fe66f62816e5d789#p265384          See also https://www.excelforum.com/excel-new-users-basics/1099995-application-index-with-look-up-rows-and-columns-arguments-as-vba-arrays.html#post4571172  , http://www.excelfox.com/forum/showthread.php/2145-Excel-VBA-Interception-and-Implicit-Intersection-and-VLookUp   for full explanation
    '3b(iv) Output to first worksheet in workbook and close and save it
     Let Ws.Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut() ' We can paste out an array of values in one go to a spreadsheet range. Here A1 is taken as top right which is then resized to the size of the field of data values in arrOut()
     Workbooks(WbNme).Close Savechanges:=True
    '3b(v) Some tidying up before we possibly go to the next unique name
     Let strRws = "1" ' we must reset this, or else we will still have row indicies in it from the last unique name
   
    Next WbCnt '  =====================================================================
End Sub

' simplified version
Sub DaDoRunRonDeDo2_()
Dim WsM As Worksheet: Set WsM = ThisWorkbook.Worksheets.Item(1)
Dim Lr As Long: Let Lr = WsM.Range("A" & WsM.Rows.Count & "").End(xlUp).Row
Dim arrA() As Variant: Let arrA() = WsM.Range("A1:A" & Lr & "").Value2
Dim Cnt As Long
    For Cnt = 2 To Lr Step 1
    Dim strUnics As String
        If InStr(strUnics, arrA(Cnt, 1)) = 0 Then strUnics = strUnics & arrA(Cnt, 1) & " "
    Next Cnt
Dim arrUnics() As String: Let arrUnics() = Split(Trim(strUnics))
Dim WbCnt As Long
    For WbCnt = 1 To UBound(arrUnics()) + 1
    Dim strRws As String: Let strRws = "1"
        For Cnt = 2 To Lr Step 1
            If arrA(Cnt, 1) = arrUnics(WbCnt - 1) Then strRws = strRws & " " & Cnt
        Next Cnt
     Workbooks.Add
    Dim WbNme As String: Let WbNme = arrUnics(WbCnt - 1) & ".xlsx"
     ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & arrUnics(WbCnt - 1) & ".xlsx"
    Dim Rws() As String: Let Rws() = Split(strRws, " ", -1, vbBinaryCompare)
    Dim RwsT() As String
     ReDim RwsT(1 To UBound(Rws()) + 1, 1 To 1)
        For Cnt = 1 To UBound(Rws()) + 1
         Let RwsT(Cnt, 1) = Rws(Cnt - 1)
        Next Cnt
    Dim arrOut() As Variant: Let arrOut() = Application.Index(WsM.Cells, RwsT(), Array(1, 2, 3))
     Let Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Worksheets.Item(1).Range("A1").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)).Value2 = arrOut()
     Workbooks(arrUnics(WbCnt - 1) & ".xlsx").Close Savechanges:=True
     Let strRws = "1"
    Next WbCnt
End Sub

Ref
https://eileenslounge.com/viewtopic.php?f=30&t=34878
https://eileenslounge.com/viewtopic....245238#p245238

**DocAElstein** · 07-26-2020, 11:45 AM

Post for later use
Required to get URL now

**DocAElstein** · 07-26-2020, 11:26 PM

In support of this Thread post
https://www.excelforum.com/excel-pro...ml#post5397531

Option Explicit and variable declaration

Hello
You can easily find lots of information on the internet that can explain Option Explicit , ( just a few examples given in the Refs below). But my take on it for you:
The simple answer to your specific question is that its not necessary, its just personal choice.
It’s all related to the issue of declaring variables – its difficult to discuss the issue of Option Explicit without discussing the variable declaration issue: In VBA it is not necessary to declare variables. If you use a variable, without an initial declaration, then it will be created “on the fly” as you use them. Mostly they will then be given the Variant type
What a code line at the top of a code module, of Option Explicit , does, is enable the option of being explicit for variable declaration. In other words, it forces you to declare all your variables: If you have this code line at the top of your code module, but then in any coding don’t declare any variable, you will get a warning error, on attempting to run your macro.

Simple Examples
Lets say you make a simple Typo, and write MyMsg , when you meant MyMsig. The following macro won’t error, but it wont give the answer you may have expected.
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub

There’s nufin there in that Message Box! – Why? – The message box is using variable MyMsg: The variables MyMsig and MyMsg were created “on the fly”, as you used them, but MyMsg has not been used yet. There is no error, but you did not get to be warned of your likely typo of writing MyMsg instead of MyMsig

The next 2 macros would warn you of undeclared variables with a compile error on attempting to run them
Option Explicit
Sub Testit()
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub

That last macro did not catch your Typo, but if you corrected that missing declaration for MyMsig, then you would still go on to get the warning of the non declared MyMsg
Option Explicit
Sub Testit()
Dim MyMsig As String
_Let MyMsig = "Hello"
_MsgBox Prompt:=MyMsg
End Sub

In fact, in the last macro you would have had the possibility to notice your mistake whilst writing the code line
MsgBox Prompt:=mymsg , provided that you had written it in lower case:
If you had written it just like that, lowercase, mymsg, - having done that, then mymsg would have stayed lowercase when you moved on to writing the next line. On the other hand, If any variable had been declared using any Uppercase characters, then on writing that variable name in lower case characters, and then moving on to the next line, that previous code line would have been changed automatically by the VB Editor to show the correct variable word, including any capital characters.
So an additional point from that experiment is that, if you do choose to declare your variables, then its worth considering using at least one capital in your variable name, but then going on when writing the variable further in the macro to use just lower case always. The VB Editor should automatically correct all your variables, ( and incidentally also correct any commands you type in lower case ) to their correct form including any upper case characters: So, if something remains lower case when you move on to writing the next code line, then you have an immediate indication that something is probably wrong, ( mostly*** ).
( The automatic capitalisation is not directly related to using Option Explicit, but is related to the issue of declaring variables. The use of Option Explicit is mostly of consideration when considering how you choose to handle your variable usage).

So you have a couple of good reason to choose to use Option Explicit and declare your variables carefully.

But you do not have to use Option Explicit
Most people prefer to declare all variables, and to use Option Explicit
There are some people , amongst them respected professionals who go against the trend, don’t use Option Explicit, and consider the use of declaration only where really needed, for example when working when working with class modules. The reasoning is usually given as to avoid redundancy in coding, keeping coding as efficient as possible.

Its personal choice. Do anyfin ya wanna do

Molly

Ref:
http://www.eileenslounge.com/viewtop...265556#p265556

http://www.eileenslounge.com/viewtopic.php?f=30&t=2281

*** Unfortunately life is not so simple with Microsoft. A bug can cause the automatic capitalization to fail. If you notice this, for example when known commands stay lowercase, then the only known cure seems to be to restart Excel and/ or your computer.

**DocAElstein** · 08-09-2020, 01:51 PM

In support of this Thread:
http://www.eileenslounge.com/viewtop...271368#p271368

Code:

    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
    ' Most borders
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
    ' Sum formulas
     Let ThisWorkbook.Worksheets("consultant doctor").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 ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
 '     First signature                 Second signature                    third signature                 Fourth signature                    Fifth signature
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
   ' Bold stuff
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
 
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
    
    ' HPageBreaks.Add
     ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")
   
    Next Cnt

Code:

Sub Solution6()  '                        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
' 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
    ' Most borders
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
    ' Sum formulas
     Let ThisWorkbook.Worksheets("consultant doctor").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 ThisWorkbook.Worksheets("consultant doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
 '     First signature                 Second signature                    third signature                 Fourth signature                    Fifth signature
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
   ' Bold stuff
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
 
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 1 & "").Value = "The total"
     Let ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
    
    ' HPageBreaks.Add
     ThisWorkbook.Worksheets("consultant doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")
   
    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
' 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
    ' Most borders
     Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
    ' Sum formulas
     Let ThisWorkbook.Worksheets("Specialist Doctor").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 ThisWorkbook.Worksheets("Specialist Doctor").Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
 '     First signature                 Second signature                    third signature                 Fourth signature                    Fifth signature
     Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
   ' Bold stuff
     Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
 
     Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 1 & "").Value = "The total"
     Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A" & Cnt + 7 & "").Value = "Previous total"
     ' HPageBreaks.Add
     ThisWorkbook.Worksheets("Specialist Doctor").HPageBreaks.Add ThisWorkbook.Worksheets("consultant doctor").Range("A" & Cnt + 7 & "")
    Next Cnt

End Sub

**DocAElstein** · 08-09-2020, 01:52 PM

In support of this Thread:
http://www.eileenslounge.com/viewtop...271368#p271368

Code:

Sub Solution7()  '                        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
' 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"
       
       ' 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
' 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"
        ' HPageBreaks.Add
         .HPageBreaks.Add .Range("A" & Cnt + 7 & "")
        End With ' ThisWorkbook.Worksheets("Specialist Doctor")
    Next Cnt

End Sub