Appendix-Thread-Evaluate-Range-(-Codes-for-other-Threads-HTML-Tables-etc-)

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

Code:

---

'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


---

Code:

---

'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


---

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

Code:

---

Sub Solution8()  '                        http://www.eileenslounge.com/viewtopic.php?p=271368#p271368            similar other recent thread: http://www.eileenslounge.com/viewtopic.php?f=30&t=35095
' Main Data worksheet
Dim arrK() As Variant: Let arrK() = ThisWorkbook.Worksheets("Main workbook").Range("K1:K" & ThisWorkbook.Worksheets("Main workbook").Range("A" & Rows.Count & "").End(xlUp).Row & "").Value
' Get row indicies for the two output worksheets
Dim strSuc As String, strSpit As String
Let strSuc = "7": Let strSpit = "7"
Dim Cnt As Long
    For Cnt = 11 To UBound(arrK(), 1)
        If arrK(Cnt, 1) = "Positive" Then  '/////////
        Let strSuc = strSuc & " " & Cnt
        Else
        Let strSpit = strSpit & " " & Cnt
        End If
    Next Cnt
'Debug.Print strSuc
' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
 Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
    For rOuter = 2 To UBound(strNms)
    Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
        For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
            If strNms(rOuter) > strNms(rInner) Then
            Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
            Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
            Dim TempRs As String
            Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0  not 1
            Else
            End If
        Next rInner ' -----------------------------------------------------------------------
    Next rOuter ' ==================End  Outer Loop===============================================================
' we must now re make strsuc
 Let strSuc = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1  to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
    Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) '          https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Next Cnt
 Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
    Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim arrOut() As Variant
 Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
 Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet  Consultant doctor
 ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
    With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
    .Font.Name = "Times New Roman"
    .Font.Size = 13
    .Columns("D:X").NumberFormat = "0.00"
    .EntireColumn.AutoFit
    End With
'
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
        With ThisWorkbook.Worksheets("consultant doctor")
      ' Most borders
        .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
      ' Sum formulas
        .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
        .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
    '                                                                    First signature                Second signature                    third signature                Fourth signature                    Fifth signature
        .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
      ' Bold stuff
        .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
      '
        .Range("A" & Cnt + 1 & "").Value = "The total"
        .Range("A" & Cnt + 7 & "").Value = "Previous total"
        ' row height for "Total" and "previous total"
        .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
        .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50      '
      ' HPageBreaks.Add
        .HPageBreaks.Add .Range("A" & Cnt + 7 & "")
        End With ' ThisWorkbook.Worksheets("consultant doctor")
       
    Next Cnt

' First half##
' Second stage output worksheet  Specialist Doctor
'Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
'Dim strRws() As String
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
' sorting with Arrays
'Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
 Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
'Dim rOuter As Long ' ========"Left Hand"========================Outer Loop=====================================
    For rOuter = 2 To UBound(strNms)
'    Dim rInner As Long ' -------Inner Loop------------"Right Hand"--------------------------
        For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
            If strNms(rOuter) > strNms(rInner) Then
'          Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
            Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
'          Dim TempRs As String
            Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0  not 1
            Else
            End If
        Next rInner ' -----------------------------------------------------------------------
    Next rOuter ' ==================End  Outer Loop===============================================================
' we must now re make strsuc
 Let strSpit = Join(strRws(), " ")
Rem Part A) modification (via string manipulation)
'Dim TotRws As Long
 Let TotRws = (Len(strSpit) - Len(Replace(strSpit, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1  to give us the number of row indicies
'Dim Segs As Long
 Let Segs = Int(TotRws / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
    Let strSpit = Application.WorksheetFunction.Substitute(strSpit, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) '          https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Next Cnt
 Let strRws() = Split(strSpit, " ", -1, vbBinaryCompare)
'Dim Rws() As String
 ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
    Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
'Dim arrOut() As Variant
 Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, Rws(), Clms())
 Let ThisWorkbook.Worksheets("Specialist Doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet  Specialist Doctor
 ThisWorkbook.Worksheets("Specialist Doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
    With ThisWorkbook.Worksheets("Specialist Doctor").UsedRange
    .Font.Name = "Times New Roman"
    .Font.Size = 13
    .Columns("D:X").NumberFormat = "0.00"
    .EntireColumn.AutoFit
    End With
'
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
        With ThisWorkbook.Worksheets("Specialist Doctor")
      ' Most borders
        .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
      ' Sum formulas
        .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
        .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
    '    First signature                Second signature                    third signature                Fourth signature                    Fifth signature
        .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
      ' Bold stuff
        .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
      '
        .Range("A" & Cnt + 1 & "").Value = "The total"
        .Range("A" & Cnt + 7 & "").Value = "Previous total"
      ' row height for "Total" and "previous total"
        .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
        .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50      '
        ' HPageBreaks.Add
        .HPageBreaks.Add .Range("A" & Cnt + 7 & "")
        End With ' ThisWorkbook.Worksheets("Specialist Doctor")
    Next Cnt

End Sub

---

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

Code:

---

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




---

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

part 2 of 3

Code:

---

' First half ##
' First stage output worksheet
Dim Clms() As Variant: Let Clms() = Array(1, 4, 6, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46)
Dim strRws() As String: Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' sorting with Arrays
Dim strNms() As Variant ' this will be the array of names in the order corresponding to the strRws() indicies
 Let strNms() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, strRws(), 6)
' Array sort of Bubble sort, sort of
Dim rOuter As Long ' ========"Left Hand"=========================Outer Loop=====================================
    For rOuter = 2 To UBound(strNms)
    Dim rInner As Long ' -------Inner Loop-------------"Right Hand"--------------------------
        For rInner = rOuter + 1 To UBound(strNms) ' from just above left hand through all the rest
            If strNms(rOuter) > strNms(rInner) Then
            Dim varTemp As Variant ' I want to Swap those 2 above ( and the corresponding strRws() ) - I cant easilly in any coding change two values simulataneosly. So one of them Element values will put in this temporary place. This Element Values will then be given the other. Finally the other Element will be given this temporary value
            Let varTemp = strNms(rOuter): Let strNms(rOuter) = strNms(rInner): Let strNms(rInner) = varTemp
            Dim TempRs As String
            Let TempRs = strRws(rOuter - 1): Let strRws(rOuter - 1) = strRws(rInner - 1): Let strRws(rInner - 1) = TempRs ' the -1 is because strRws() starts at 0  not 1
            Else
            End If
        Next rInner ' -----------------------------------------------------------------------
    Next rOuter ' ==================End  Outer Loop===============================================================
' we must now re make strsuc
 Let strSuc = Join(strRws(), " ")
 
 
Rem Part A) modification (via string manipulation)
Dim TotRws As Long: Let TotRws = (Len(strSuc) - Len(Replace(strSuc, " ", "", 1, -1, vbBinaryCompare))) + 1 ' effectively we are determining the number or spaces between the row indicies, then +1  to give us the number of row indicies
Dim Segs As Long: Let Segs = Int(TotRws / 27) + 1
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) - 34 Step 34
    Let strSuc = Application.WorksheetFunction.Substitute(strSuc, " ", " 1 1 1 1 1 1 1 ", Cnt - 6) '          https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
    Next Cnt
' I need my array to be  like 137 rather than like 109  strRws()  is  0 To 108  ,
' 137  is  ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1
' Missing is  ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1  -  (UBound(strRws()) + 1)
 Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' At this point we have all the rows with data and the inbetween inserted rows, but we want to extent the output array enough to have the entire range so that I can also paste out the final words and formulas in it
Dim LstEmptyRws As Long: Let LstEmptyRws = ((Segs * 27) + ((Segs - 1) * 7) + 7) + 1 - (UBound(strRws()) + 1)
 Let strSuc = strSuc & "" & Evaluate("=REPT("" 1""," & LstEmptyRws & ")") ' ' Because we start with a number, we can add like this  & " 4"  so don't habe a last space to remove
 Let strRws() = Split(strSuc, " ", -1, vbBinaryCompare)
' Stop
Dim Rws() As String: ReDim Rws(1 To UBound(strRws(), 1) + 1, 1 To 1)
    For Cnt = 1 To UBound(strRws(), 1) + 1
    Let Rws(Cnt, 1) = strRws(Cnt - 1)
    Next Cnt
Dim RwsT() As Variant, ClmsT() As Variant
 Let ClmsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")")                                    '  "vertical"    1 2 3 4 5 6  .....
 Let RwsT() = Evaluate("=Row(1:" & UBound(strRws()) + 1 & ")/row(1:" & UBound(strRws()) + 1 & ")")  '  "vertical"    1 1 1 1 1 1 1    .....
 Let RwsT() = Application.Index(strRws(), RwsT(), ClmsT())
Dim arrOut() As Variant ' This is the main output, all in one go. But we can put some values into the array before...
 Let arrOut() = Application.Index(ThisWorkbook.Worksheets("Main workbook").Cells, RwsT(), Clms())
'  ... we can put some values (words) and formulas into the array before we paste it out
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34  '  ... we can put some values into the array before...
    Let arrOut(Cnt + 1 - 6, 1) = "The total" '  -6 is because we have top right of A7
    Let arrOut(Cnt + 7 - 6, 1) = "Previous total"
    Dim Cl As Long  '  formulas
        For Cl = 4 To 24 '  D To X
        Let arrOut(Cnt + 7 - 6, Cl) = "=R[-6]C" ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
        ' .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
        Let arrOut(Cnt + 1 - 6, Cl) = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
        Next Cl
    '                                                                    First signature                Second signature                    third signature                Fourth signature                    Fifth signature
        ' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
    Let arrOut(Cnt + 2 - 6, 2) = "First signature"
    Let arrOut(Cnt + 2 - 6, 7) = "Second signature"
    Let arrOut(Cnt + 2 - 6, 12) = "Third signature"
    Let arrOut(Cnt + 2 - 6, 17) = "Forth signature"
    Let arrOut(Cnt + 2 - 6, 22) = "Fifth signature"
'    Let arrOut(Cnt + 2 - 6, 2) = "First signature"
'    Let arrOut(Cnt + 2 - 6, 2) = "First signature"
    Next Cnt
' Main paste out of all data and some words and formulas
 Let ThisWorkbook.Worksheets("consultant doctor").Range("A7").Resize(UBound(arrOut(), 1), UBound(arrOut(), 2)) = arrOut()

'Second half worksheet  Consultant doctor
 ThisWorkbook.Worksheets("Consultant doctor").Rows("7:7").RowHeight = 50 ' Header row
' Main formatting
    With ThisWorkbook.Worksheets("Consultant doctor").UsedRange
    .Font.Name = "Times New Roman"
    .Font.Size = 13
    .Columns("D:X").NumberFormat = "0.00"
    .EntireColumn.AutoFit
    End With
'
    For Cnt = 34 To ((Segs * 27) + ((Segs - 1) * 7) + 7) Step 34
        With ThisWorkbook.Worksheets("consultant doctor")
      ' Most borders
        .Range("A" & Cnt & "").Offset(-27, 0).Resize(29, 24).Borders.LineStyle = xlContinuous
      ' Sum formulas
        '  .Range("D" & Cnt + 1 & ":X" & Cnt + 1 & "").Value = "=IF(SUM(R[-28]C:R[-1]C)=0,"""",SUM(R[-28]C:R[-1]C))"
        ' .Range("D" & Cnt + 7 & ":X" & Cnt + 7 & "").Value = "=R[-6]C"
    '                                                                    First signature                Second signature                    third signature                Fourth signature                    Fifth signature
        ' .Range("A" & Cnt + 2 & ":X" & Cnt + 2 & "").Value = Array("", "First signature", "", "", "", "", "Second signature", "", "", "", "", "Third signature", "", "", "", "", "Fourth signature", "", "", "", "", "Fifth Signature", "", "")
      ' Bold stuff
        .Range("A" & Cnt & "").Offset(1, 0).Resize(7, 24).Font.Bold = True
      '
        ' .Range("A" & Cnt + 1 & "").Value = "The total"
        ' .Range("A" & Cnt + 7 & "").Value = "Previous total"
        ' row height for "Total" and "previous total"
        .Range("A" & Cnt + 1 & "").EntireRow.RowHeight = 50
        .Range("A" & Cnt + 7 & "").EntireRow.RowHeight = 50      '
      ' HPageBreaks.Add
        .HPageBreaks.Add .Range("A" & Cnt + 7 & "")
        End With ' ThisWorkbook.Worksheets("consultant doctor")
       
    Next Cnt
' delete  last unwanted  Previous Total  row
 ThisWorkbook.Worksheets("consultant doctor").Rows(((Segs * 27) + ((Segs - 1) * 7) + 7) + 7).Delete shift:=xlUp '  http://www.eileenslounge.com/viewtopic.php?p=271328#p271328    ....Go back to my first post, and look at my maths logic. In the macro we have  ((Segs * 27) + ((Segs - 1) * 7) + 7)  This returns us for consultant doctor 136 and for worksheet Specialist Doctor 102  I think you can see how to get 143 and 109 from those two numbers ( I will give you a clue: The answer is +7 )...."
' End first stage worksheet___________________________________________________________________________________________

'

---

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

part 3 of 3

Code:

---

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


---

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

Code:

---

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

---

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

Code:

---

'                                        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

Code:

---

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

---

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

Code:

---

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

---

Quote:

---

Originally Posted by vba_php

....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… )

Quote:

---

Originally Posted by vba_php

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

Code:

---

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

Some additional notes and extended explanations in support of answer to this Thread
https://eileenslounge.com/viewtopic....fc302dc186f01b

The OP has this
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )

Row\Col	A	B	C	D	E	F	G
1	Header1	Header2	Header3	Header4	Header5	Header6	Header7
2	101	H2_1	H3_1	H4_1	H5_1	H6_1	H7_1
3	102	H2_2	H3_2	H4_2	H5_2	H6_2	H7_2
4	103	H2_3	H3_3	H4_3	H5_3	H6_3	H7_3
5	102	H2_4	H3_4	H4_4	H5_4	H6_4	H7_4
6	101	H2_5	H3_5	H4_5	H5_5	H6_5	H7_5
7	103	H2_6	H3_6	H4_6	H5_6	H6_6	H7_6
8	105	H2_7	H3_7	H4_7	H5_7	H6_7	H7_7
9	104	H2_8	H3_8	H4_8	H5_8	H6_8	H7_8

Worksheet: Source

This what the OP wants
_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )

Row\Col	C	D	E	F
2	MyTarget	Header3	Header4	Header7
3	101	H3_1	H4_1	H7_1
4	101	H3_5	H4_5	H7_5
5	101
6	102	H3_2	H4_2	H7_2
7	103	H3_3	H4_3	H7_3
8	103	H3_6	H4_6	H7_6
9	104	H3_8	H4_8	H7_8
10	108
11	105	H3_7	H4_7	H7_7

Worksheet: Target

Here again what the OP wants, with explanations:

	Expected Result
MyTarget	Header3	Header4	Header7
101	H3_1	H4_1	H7_1		first instance
101	H3_5	H4_5	H7_5		second instance
101					third instance (there is no third instance so left empty)
102	H3_2	H4_2	H7_2
103	H3_3	H4_3	H7_3
103	H3_6	H4_6	H7_6
104	H3_8	H4_8	H7_8
108					left empty as there is no 108 in Source
105	H3_7	H4_7	H7_7

You can see that it comes from the source worksheet:

Header1	Header2	Header3	Header4	Header5	Header6	Header7
101	H2_1	H3_1	H4_1	H5_1	H6_1	H7_1
102	H2_2	H3_2	H4_2	H5_2	H6_2	H7_2
103	H2_3	H3_3	H4_3	H5_3	H6_3	H7_3
102	H2_4	H3_4	H4_4	H5_4	H6_4	H7_4
101	H2_5	H3_5	H4_5	H5_5	H6_5	H7_5
103	H2_6	H3_6	H4_6	H5_6	H6_6	H7_6
105	H2_7	H3_7	H4_7	H5_7	H6_7	H7_7
104	H2_8	H3_8	H4_8	H5_8	H6_8	H7_8

---

Rem 1
The main start point on my logic is obtaining ( in a dynamic way ) a range ( in an array , arrSrch() , ) that looks like this

Header1	Header3	Header4	Header7
101	H3_1	H4_1	H7_1
102	H3_2	H4_2	H7_2
103	H3_3	H4_3	H7_3
102	H3_4	H4_4	H7_4
101	H3_5	H4_5	H7_5
103	H3_6	H4_6	H7_6
105	H3_7	H4_7	H7_7
104	H3_8	H4_8	H7_8

Note: The array arrSrch() has an extra empty row
https://imgur.com/fKjli8W https://i.imgur.com/fKjli8W.jpg


What we do with that is the subject of Rem 2 , and is explained in the next post

Continued from last post

Rem 2
We build up a Main 1D array whose elements are themselves 1 D arrays of the required output rows.
This is done by looping down the target range rows , arTgt() = WsT.Range("C2:C" & LrT & "").Value
At each loop we look for a match of the target range row value in the first column of arrSrch()
We then do the array Split type technique ( https://excelfox.com/forum/showthrea...lication-Index ) to get a 1 D array of the required row. That row is added to the Main 1 D array
We then remove that row from arrSrch() ( using a function from Rick Rothstein https://excelfox.com/forum/showthrea...-Variant-Array ).
Then we move on to the next target range row down

Rem 3
Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in Index as a 2D array https://eileenslounge.com/viewtopic....266691#p266691
For demo purposes, the macro in the next post pastes out the result in a spare worksheet range:

Code:

---

' Example paste out  CHANGE  Top left cell  H35  to suit
 Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut()                ' ** -1 is a bodge to knock off the extra row
End Sub


---

_____ Workbook: SampleSept2020.xlsm ( Using Excel 2007 32 bit )

Row\Col	H	I	J
35	H3_1	H4_1	H7_1
36	H3_5	H4_5	H7_5
37
38	H3_2	H4_2	H7_2
39	H3_3	H4_3	H7_3
40	H3_6	H4_6	H7_6
41	H3_8	H4_8	H7_8
42
43	H3_7	H4_7	H7_7

Worksheet: Target

Macro, Sub BrdShlss() , and a couple of required Functions are here:
https://excelfox.com/forum/showthrea...ll=1#post14907

Macro for these posts
https://excelfox.com/forum/showthrea...ll=1#post14905
https://excelfox.com/forum/showthrea...ll=1#post14906
http://www.eileenslounge.com/viewtopic.php?f=30&t=35303

Code:

---

Option Explicit
Sub BrdShlss() '  http://www.eileenslounge.com/viewtopic.php?f=30&t=35303  https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=14907&viewfull=1#post14907
Rem 1 worksheets data info
Dim WsS As Worksheet, WsT As Worksheet
 Set WsS = ThisWorkbook.Worksheets("Source"): Set WsT = ThisWorkbook.Worksheets("Target")
Dim LrS As Long, LrT As Long, LcS As Long, LcT As Long
 Let LrS = WsS.Range("A" & WsS.Rows.Count & "").End(xlUp).Row
 Let LrT = WsT.Range("C" & WsT.Rows.Count & "").End(xlUp).Row
 Let LcS = WsS.Cells(1, WsS.Columns.Count).End(xlToLeft).Column
 Let LcT = WsT.Cells(2, WsT.Columns.Count).End(xlToLeft).Column
Dim arSrc() As Variant ', arSrcA() As Variant
 Let arSrc() = WsS.Range("A1:" & CLtr(LcS) & LrS + 1 & "").Value  '  + 1 is to give us an extra empty row
' Let arSrcA() = WsS.Range("A1:A" & LrS & "").Value
Dim arTgt() As Variant: Let arTgt() = WsT.Range("C2:C" & LrT & "").Value
'1b) determine what columns are needed for our search range, since typically not all are needed
Dim strClms As String: Let strClms = "1"
Dim SrchHd() As Variant: Let SrchHd() = WsT.Range("D2:" & CLtr(LcT) & "2").Value
Dim SrcHd() As Variant: Let SrcHd() = WsS.Range("A1:" & CLtr(LcS) & "1").Value
Dim Cnt As Long
    For Cnt = 1 To UBound(SrchHd(), 2)
    Dim MtchRes As Long ' Note I assume there is always a match in Headers between sheet ranges, so that I always have a number and not an error string
    Let MtchRes = Application.Match(SrchHd(1, Cnt), SrcHd(), 0)
    Let strClms = strClms & " " & MtchRes  ' add a required column indicie
   
    Next Cnt
' Let strClms = Left(strClms, (Len(strClms) - 1)) ' remove last unwanted space  For the given example this gives us  "3 4 7"
Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & LrS + 1 & ")") '  + 1 is to give us an extra empty row
Dim arrSrch() As Variant ' This will be the reduced size range we need to search in - it has just the headers required
 Let arrSrch() = Application.Index(arSrc(), RwsT(), Split(strClms, " ", -1, vbBinaryCompare)) ' In our example  Split(strClms, " ", -1, vbBinaryCompare))  is  {1, 3, 4, 7)
' Let Range("H24").Resize(UBound(arrSrch(), 1), UBound(arrSrch(), 2)).Value = arrSrch()
'1c) Get initial row string indicies for current source range
'Dim RwsT() As Variant: Let RwsT() = Evaluate("=Row(1:" & UBound(arSrc(), 1) & ")") ' Typical "vertical" array of row indices needed in  Index(Arr, Rws(), Clms())  type code line
'Dim Rws() As Variant: Let Rws() = Application.Index(RwsT(), Evaluate("=Column(A:" & CLtr(UBound(RwsT, 1)) & ")"), Evaluate("=Column(A:" & CLtr(UBound(RwsT(), 1)) & ")/Column(A:" & CLtr(UBound(RwsT(), 1)) & ")")) '  Transpose the  "vertical array to get a 1 Dimenrional "horizontal" array
'Dim strRws As String: Let strRws = " " & Join(Rws(), " ") & " " ' This is a string of our row indicies, and later we will remove some indicies as we go along then work the steps above backwards to get a modified  RwsT()  to use in  Index(Arr, Rws(), Clms())  type code line  for a new reduced content search array
Rem 2 Building output array
Dim arrOut() As Variant ' A 1 D array for the 1 D arrays at each match
' 2b) main loop for all rows of  MyTarget
    For Cnt = 2 To UBound(arTgt(), 1) Step 1
    ReDim Preserve arrOut(1 To Cnt - 1)
    Dim arSrcA() As Variant: Let arSrcA() = Application.Index(arrSrch(), 0, 1) ' the first column of our current  arrSrch()    '  https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
    Dim VarMtchres As Variant
    Let VarMtchres = Application.Match(arTgt(Cnt, 1), arSrcA(), 0)
        If IsError(VarMtchres) Then ' we need to add an empty row which we have as the last row of  arrSrch()
        Let arrOut(Cnt - 1) = Application.Index(arrSrch(), UBound(arrSrch(), 1), 0)                                          '  https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
        Else
        Let arrOut(Cnt - 1) = Application.Index(arrSrch(), VarMtchres, 0)                                                    '  https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%e2%80%93-Application-Index
    '2b(ii) we must remove the row from the arrSrch()
        Let arrSrch() = DeleteArrayRow(arrSrch(), (VarMtchres))
        End If
    Next Cnt
Rem 3  '  Our output array is a 1D array of 1D arrays , but we noticed that we can treat that in  Index  as a 2D array  https://eileenslounge.com/viewtopic.php?p=266691#p266691
 Let arrOut() = Application.Index(arrOut(), RwsT(), Evaluate("=Column(B:" & CLtr(UBound(arrSrch(), 2)) & ")"))  ' ** this is actually 1 row too big
' Example paste out  CHANGE  Top left cell  H35  to suit
 Let WsT.Range("H35").Resize(UBound(arrOut(), 1) - 1, UBound(arrOut(), 2)).Value = arrOut()                ' ** -1 is a bodge to knock off the extra row
End Sub

'  https://excelfox.com/forum/showthread.php/2083-Delete-One-Row-From-A-2D-Variant-Array
Function DeleteArrayRow(Arr As Variant, RowToDelete As Long) As Variant
  Dim Rws As Long, Cols As String
  Rws = UBound(Arr) - LBound(Arr)
  Cols = "A:" & Split(Columns(UBound(Arr, 2) - LBound(Arr, 2) + 1).Address(, 0), ":")(0)
  DeleteArrayRow = Application.Index(Arr, Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(Arr) & ")"))))), Evaluate("COLUMN(" & Cols & ")"))
End Function

'  https://excelfox.com/forum/showthread.php/1902-Function-Code-for-getting-Column-Letter-from-Column-Number
Public Function CLtr(ByVal lclm As Long) As String '        http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213980
    Do: Let CLtr = Chr(65 + (((lclm - 1) Mod 26))) & CLtr: Let lclm = (lclm - (1)) \ 26: Loop While lclm > 0
End Function

---