Appendix Thread. App Index Rws() Clms() Majic code line Codings for other Threads, Tables etc.)

[DocAElstein]

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]

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

    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

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]

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

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

[DocAElstein]

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

'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

'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

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989

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

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989
Part 1 of 3

Sub Solution8b()  '                        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" ' Because we start with a number, we can add like this  & " 4"  so don't habe a last space to remove
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
         Let strSuc = strSuc & " " & Cnt  ' Because we start with a number, we can add like this  & " 4"  so don't habe a last space to remove
        Else
         Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
'Debug.Print strSuc

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989

part 2 of 3

' 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___________________________________________________________________________________________

'

[DocAElstein]

In support of this Thread post
http://www.eileenslounge.com/viewtop...272989#p272989

part 3 of 3

'
' 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)
' 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 strSpit = strSpit & "" & 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(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 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
 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("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
' delete  last unwanted  Previous Total  row
 ThisWorkbook.Worksheets("Specialist 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 Sub

[DocAElstein]

In support of this Post
https://eileenslounge.com/viewtopic....273285#p273285

Sub Solution9ProObfuscation()
Application.ScreenUpdating = False
Dim arrK() As Variant:  arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
Dim strSuc As String, strSpit As String
 strSuc = "7":  strSpit = "7"
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then
          strSuc = strSuc & " " & Cnt
        Else
          strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
Dim Clms() As Variant:  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:  strRws() = Split(strSuc)
Dim strNms() As Variant: strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
Dim rOuter As Long
    For rOuter = 2 To UBound(strNms)
    Dim rInner As Long
        For rInner = rOuter + 1 To UBound(strNms)
            If strNms(rOuter) > strNms(rInner) Then
            Dim varTemp As Variant
              varTemp = strNms(rOuter):  strNms(rOuter) = strNms(rInner):  strNms(rInner) = varTemp
            Dim TempRs As String
              TempRs = strRws(rOuter - 1):  strRws(rOuter - 1) = strRws(rInner - 1):  strRws(rInner - 1) = TempRs
            Else
            End If
        Next rInner
    Next rOuter
 strSuc = Join(strRws(), " ")
Dim Segs As Long:  Segs = Int(((Len(strSuc) - Len(Replace(strSuc, " ", ""))) + 1) / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
      strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6)
    Next Cnt
 strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(Split(strSuc)) + 1) & ")"): strRws() = Split(strSuc)
Dim arrOut() As Variant
  arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms())
    With ThisWorkbook.Worksheets("consultant doctor")
        For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
         arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total"
        Dim Cl As Long
            For Cl = 4 To 24
              arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
            Next Cl
         arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
        .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
        .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
        .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50
        .HPageBreaks.Add .Range("A" & Cnt + 7 & "")
        Next Cnt
    .Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
        With .UsedRange
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .Columns("D:X").NumberFormat = "0.00"
        .EntireColumn.AutoFit
        End With
    .Rows("7:7").RowHeight = 50
    .Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete
    End With
  strRws() = Split(strSpit)
  strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
    For rOuter = 2 To UBound(strNms)
        For rInner = rOuter + 1 To UBound(strNms)
            If strNms(rOuter) > strNms(rInner) Then
              varTemp = strNms(rOuter):  strNms(rOuter) = strNms(rInner):  strNms(rInner) = varTemp
              TempRs = strRws(rOuter - 1):  strRws(rOuter - 1) = strRws(rInner - 1):  strRws(rInner - 1) = TempRs
            Else
            End If
        Next rInner
    Next rOuter
  strSpit = Join(strRws(), " ")
  Segs = Int(((Len(strSpit) - Len(Replace(strSpit, " ", ""))) + 1) / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
      strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6)
    Next Cnt
  strRws() = Split(strSpit)
  strSpit = strSpit & "" & Evaluate("=REPT("" 1""," & ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1) & ")")
  strRws() = Split(strSpit)
  arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Application.Index(strRws(), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")"), Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")), Clms())
    With ThisWorkbook.Worksheets("Specialist Doctor")
        For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
          arrOut(Cnt + 1 - 6, 1) = "The total": arrOut(Cnt + 7 - 6, 1) = "Previous total"
            For Cl = 4 To 24
             arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C": arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
            Next Cl
          arrOut(Cnt + 2 - 6, 2) = "First signature": arrOut(Cnt + 2 - 6, 7) = "Second signature": arrOut(Cnt + 2 - 6, 12) = "Third signature": arrOut(Cnt + 2 - 6, 17) = "Forth signature": arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
        .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
        .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
        .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50: .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50
        .HPageBreaks.Add .Range("A" & Cnt + 7 & "")
        Next Cnt
    .Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()
        With .UsedRange
        .Font.Name = "Times New Roman"
        .Font.Size = 13
        .Columns("D:X").NumberFormat = "0.00"
        .EntireColumn.AutoFit
        End With
    .Rows("7:7").RowHeight = 50
    .Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete
    End With
Application.ScreenUpdating = True
End Sub

[DocAElstein]

In support of these Threads
' https://www.ozgrid.com/forum/index.p...ng-a-2d-array/
' https://www.excelforum.com/excel-pro...dim-array.html
https://www.excelforum.com/tips-and-...ml#post5408376





I am not totally sure what the OP is asking.
Is the OP asking
(i) _ to put values into an existing array where that existing array already has values in it
or
(ii)_ changing the array dimension and positioning of elements in an array
or
(iii)_ maybe its lost in the translation and/ or the OP is not sure him/herself.
The initial answer to (i)_ I think we seem clear about:- It will likely in VBA require a code line for each element to be “moved” from one array to the other , so likely looping will be involved for a multi element array.
The Thread title and OPs first question infers to me converting a 1 D array to a 2 D array, without looping.
If the existing array with values already in it is a dynamic array, then overwriting along with re dimensioning means that those (i)_ and (ii)_ are somewhat merged in meaning anyway.
So I am not totally clear what is going on here, but I think it there is a discussion of generally … …”1 D arrays to 2 D arrays”
So lets say we are talking generally about …”1 D arrays to 2 D arrays” and leave it loosely defined for now and go with that…

Frederick has shown in his second code line that a characteristic of the Transpose function is that if a 1 D array is given to the Transpose function then the transposed array becomes a 2 D array , all be it a quasi “1 column array” ***
Transpose does that, as it does the opposite way converting a single column 2D array to a 1D array.
I think most of us are not quite sure why it has been wired to do that. Some other things seem to default to making a “one row” thing be a 1D array rather than a 2D array, even when the thing it may have been given to work on was a 2D array. ( It does not screw things up to badly when playing with spreadsheets since that transposed in its final 1 D form will be “seen” by Excel as if it was a single row 2 Dimensional array when applied to a spreadsheet range. So usually a “row” becomes a row, if you catch my drift).
We can go the other way. ( If we do that with Rick’s example , we will see a small difference, the 1 D array returned will have indices of 1 2 3 4 5 as opposed to the 0 1 2 3 4 , (since the Split function Rick used returns those starting a base 0 ) . I am not sure why Excel chooses to start a t 1 in this case: Possibly it was just made that way because its more often to do with worksheet/spreadsheet stuff, and we think about rows and columns starting at 1, and something like a row of 1 is a bit stupid. )

Index with arrays as co ordinate arguments
This stuff is worth knowing about:
A further function that can be very helpful in doing this sort of manipulation of arrays without looping is the Index Function. It becomes so useful because it will accept arrays in place of the more conventional single value indices in its second ( row ) and third ( column ) arguments. The evaluation is then done in the conventional Excel way, “along the columns of a row” , then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row, then down to repeat at the next row: along the columns of that row , ….etc. Usually VBA will do its best to give out the results in an array dimensioned appropriate for the array dimensions supplied in those second and third arguments, following the conventional “along the columns of a row” , then down to repeat at the next row: along the columns of that row, ………

As example we can do that Transpose code line in this pseudo way

'                                        Index(OneDimensionalArray(),  1                           ,       1
'                                                                      1                                   2
'                                                                      1                                   3
'                                                                      1                                   4
'                                                                      1                                   5               )

We are doing 5 calculations there, talking each time the first row and consecutive columns, the result coming out in a form that the Excel calculations are done - .. “along the columns of a row” , then down to repeat at the next row… but we only have one column in this case, so that is actually just going down the rows, 5 times. Hence our output is the 90degree transpose of OneDimensionalArray()

That was just one example, but the important point is that you can supply different arrays in the Index second ( “row” ) and third ( “column” ) arguments. So you can pretty well take any1 or 2 D array in the Index first argument, and in one code line, without looping , put all or some of the values from that array in some other order in any other 1 or 2 D array. That could be what the OP was asking for ….
Dim Array1(2, 2) As Integer
Dim Array2(2) As Integer
…………… way to copy the values from Array2 into Array1?
The restriction is that we can’t make use of this to put values into Array1( ) if it already existed. You would have to be in like having
Dim Array1() As Variant
Dim Array2(2) As Integer
-……..
Array1()= Index ( Array2(2) , { _.... } , { _... } )
( Variant is needed in the first declaration as the index chucks its output values housed in Variant types. AFAIK the first argument can be any sort of 1 D or 2 D array, ( or it can be any range object ) )

Another not looping option to assist in a conversion could be to remove rows or columns of a 2 D array with a single code line. Best look at some posts of Rick ( Frederick Rothstein ‘s ) , stuff for that ( https://excelfox.com/forum/showthrea...-Variant-Array )


One last curiosity , a weird thing I only recently came across. An array of arrays, sometimes refereed as a “jagged array”, is peculiarly treated in some cases by Index as a 2 D array. This gives us some interesting further one liner code line possibilities.
Example, If I had a 1 D array of 1 D arrays, something of this sort of form
{ { “Head1” , 2, 3 } , {“Head3”, 4, 5 } , {“Haed2”, 7, 9} }
then I can convert that, for example, to re ordered in data columns like this

'  Head1  ,  Haed2  ,  Head3
'    2    ,    7    ,  4
'    3    ,    9    ,  5

I can do that using like a Index one code liner pseudo

'                                Index(  Head1 , 2, 3          1  ,    3   ,   2                  1  ,  1   ,  1
'                                        Head3 , 4, 5          1  ,    3   ,   2                  2  ,  2   ,  2
'                                        Haed2 , 7, 9          1  ,    3   ,   2                  3  ,  3   ,  3          )

I put some more details of all I have been saying , in a macro in the uploaded file. Probably its best to step through the macro in Debug mode ( do that by hitting Key F8 after clicking anywhere in the macro )

---

....to be honest with you I've never seen your type of question asked in 20 years of writing code my lifetime. ....

Hello Adam.
I expect you are referring specifically to the idea of putting existing values from an array into another existing array, although I am not fully clear if the OP wanted that: Possibly the language barrier prevented the OP getting anything out of the links you gave him…. The best thing probably, as Rory asked for, was an example from the OP of what he wanted to do…
Anyway, you probably know all the following, but I thought I’d add it to the Thread, while I am in the mood…
Generally questions along the lines of “1 D array to 2 D array” or visa versa are quite common in Excel VBA. I expect this is because
_ a) a lot of things done “internally” in coding involve 1 D arrays,
but/ and
_ b) a range from a spreadsheet will often likely end up in an array of 2 Dimensions, I think Excel does this so that we can make the distinction what is a row and what is a column.***
So things might not always work as we wanted, for example a problem might occur when a 1 D array appears when a 2 D array was expected/ wanted, and visa versa. To solve the problem a conversion from a 1D to 2D or visa versa might get us out of trouble.
Example: we got a Join function that is something like the reverse of the Split function mentioned in this Thread . Basically you can use it to join the contents of an array into a string. The bummer is that it only accepts a 1 D array. So if I give it a column or row of data to join it will error. You’ll need to change the 2D array got from a spreadsheet single row or a spreadsheet single column to a 1D array for join to work on it. ( One way you can do that is with some of the one liner codings I been talking about – I added a example for you in the uploaded macro ### )

***I suppose a 2 D array does not really have “rows” and “columns”, it simply has 2 dimensions. But Excel conventionally puts a spreadsheet row into the fist dimension, and a spreadsheet column into the second dimension. So after using Excel VBA arrays a lot you often get to think of a 2 D array in terms of like arr(row, column) or in terms of orientation like arr(horizontal, vertical). Its just a convenient frame of reference perception.
A 1 D array has no orientation. I can’t really perceive that unless I have drunk a lot of Jack Daniels, as the world starts spinning around, then it becomes very clear, relatively speaking. I suppose Excel can’t get drunk, and as mentioned, a 1 D array seems to be often regarded as like a 2 D array of first dimension size of 1, or pseudo 1 “row” 2 D array.

Molly







Adam, I have definitely had random occurrences of an error like you mentioned, all be it very rarely. When it has happened , I was pretty damm sure it shouldn’t have happened.
I think we all agree that Activateing and Selecting when dealing with worksheet ranges via VBA is rarely needed and is usually a bad idea as the interaction with a spreadsheet slams the brakes on.

I will usually optimise a macro first, with no Activateing and Selecting , ignoring the odd error of that sort you mentioned.
After that I will often see if I don’t compromise the performance much if I add an occasional code line pair of something like
Worksheet("x").Activate: Worksheet("x").Range("A1").Select
Or, if dealing with multiple open workbooks,
Workbooks("x“).Activate: Worksheet("x").Activate: Worksheet("x").Range("A1").Select
at some strategic points.

A typical point would be just before I start doing things to ranges in Worksheet("x") via VBA. I know those two ( three ) code lines should be unnecessary. But it’s been my experience that they help stop that occasional error.
I have no idea what causes the occasional error when all suggest it should not error. I think possibly Excel has some memories of what was last active. Possibly that can become corrupted, and doing a quick Worksheet("x").Activate: Worksheet("x").Range("A1").Select refreshes it.

One thing that has already been touched on here in the Thread a couple of times, which has caught me out a few times: Selecting a range does not activate the worksheet of the range you select.
If the worksheet is not active and you try to select that range then you will get that error.
But selecting a worksheet does activate that worksheet. (Activateing and Selecting a worksheet do something similar, - I think the main difference being that you can select things, but only activate a thing. I have not explored that much yet… )

…but based on the millions of tests that I ran, it became evident that this line of code automatically made the book active:

wbDrawings.SaveAs (ThisWorkbook.Path & Application.PathSeparator & "temp.csv")

.....

I would hazard a guess that that might be version dependent and possibly unreliable, as Rory suggested. That dose not consistently activate the workbook being saved, for me.

Molly