Printable View
macro or this Post:
https://excelfox.com/forum/showthrea...ll=1#post15165
Code:Sub ConcatWithStyles() ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687
Rem 0a save the formulas, and replace with values
Dim arrFormulas() As Variant
Let arrFormulas() = Range("A1:F1").Formula
Let Range("A1:F1").Value = Range("A1:F1").Value
Dim X As Long, Cell As Range, Text As String, Position As Long
Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1"))
Position = 1
' Application.ScreenUpdating = False
For Each Cell In Range("A1:F1")
With Range("A3")
.Characters(Position, Len(Cell.Value)).Text = Cell.Characters(1, Len(Cell.Value)).Text
For X = 1 To Len(Cell.Value)
With .Characters(Position + X - 1, 1).Font
.Name = Cell.Characters(X, 1).Font.Name
.Size = Cell.Characters(X, 1).Font.Size
.Bold = Cell.Characters(X, 1).Font.Bold
.Italic = Cell.Characters(X, 1).Font.Italic
.Underline = Cell.Characters(X, 1).Font.Underline
.Color = Cell.Characters(X, 1).Font.Color
.Strikethrough = Cell.Characters(X, 1).Font.Strikethrough
.Subscript = Cell.Characters(X, 1).Font.Subscript
.Superscript = Cell.Characters(X, 1).Font.Superscript
.TintAndShade = Cell.Characters(X, 1).Font.TintAndShade
.FontStyle = Cell.Characters(X, 1).Font.FontStyle
End With
Next
End With
Position = Position + Len(Cell.Value) + 1
Next
Application.ScreenUpdating = True
Rem 0b Put the formulas back
Let Range("A1:F1").Formula = arrFormulas()
End Sub
In support of these Thread answers:
' ' https://www.mrexcel.com/board/thread.../#post-3954687 https://excelfox.com/forum/showthrea...ll=1#post15170
It was seen ( https://excelfox.com/forum/showthrea...ll=1#post15168
https://excelfox.com/forum/showthrea...ll=1#post15167 ) when solving the formula in cell issue, that the cells containing the formula can only have a single style for all characters in the cell. So it’s not necessary to loop through the characters in each cell when setting the style in the concatenated string from those cells.
Code:' ' https://www.mrexcel.com/board/threads/the-hardest-question-in-excel-history-a-very-smart-vba-macro-to-combine-cell-with-their-styles.808781/#post-3954687 https://excelfox.com/forum/showthread.php/2679-Concatenate-with-style?p=15170&viewfull=1#post15170
Sub ConcatWithStyles3()
Dim RngSel As Range: Set RngSel = Selection: Set RngSel = Range("A1:F1")
Rem 0a save any formulas, and replace with values
Dim arrFormulas() As Variant
Let arrFormulas() = RngSel.Formula ' Assuming wew select more than one cell, we will always be presented by .Value a 2 dimensional array, ( even if it is a single row or single column ) This codel line will error if we are using a selection of one cell, since in that case .Value only returns a single value which VBA syntax does not allow to be assigned to a dynmic array
Dim RwCnt As Long, ClmCnt As Long
' For RwCnt = 1 To RngSel.Rows.Count ' At each row we...._
' For ClmCnt = 1 To RngSel.Columns.Count
' If Left(arrFormulas(RwCnt, ClmCnt), 1) = "=" Then ' case a formula in cell
' Let RngSel.Item(RwCnt, ClmCnt).Value = RngSel.Item(RwCnt, ClmCnt).Value ' replace the formula with its value
' Else
' End If
' Next ClmCnt
' Next RwCnt
Dim RwsCnt As Long, ClmsCnt As Long, Itm As Long, ItmCnt As Long
Let ItmCnt = RngSel.Cells.Count
Let RwsCnt = RngSel.Rows.Count: Let ClmsCnt = RngSel.Columns.Count
For Itm = 1 To ItmCnt
If Left(arrFormulas(Int((Itm - 1) / ClmsCnt) + 1, Int((Itm - 1) / RwsCnt) + 1), 1) = "=" Then ' case a formula in cell
Let RngSel.Item(Itm).Value = RngSel.Item(Itm).Value ' replace the formula with its value
Else
End If
Next Itm
Dim ExChr As Long, ACel As Range, TeExt As String, Position As Long
' Let Range("A3").Value = Space(Evaluate("SUM(LEN(A1:F1))+COLUMNS(A1:F1)-1")) ' This makes a teExt of spaces. The number of spaces is the sum of all the teExt in the cells + one less than the number of cells. This gives us enough characters for all the teExt and a space betweeen them
Let Range("A3").Value = Space(Evaluate("=SUM(LEN(" & RngSel.Address & "))+COLUMNS(" & RngSel.Address & ")-1"))
Let Position = 1
' Let Application.ScreenUpdating = False ' adding this code line may speed the macro up a bit
Let Itm = 0
For Each ACel In RngSel
Let Itm = Itm + 1
With Range("A3") ' The range ( cell ) used for final output of concatenated cell text with styles
'here in next code line we put the characters in...
.Characters(Position, Len(ACel.Value)).Text = ACel.Value ' ACel.Characters(1, Len(ACel.Value)).Text ' ACel.Value This puts the charascters
If Left(arrFormulas(Int((Itm - 1) / ClmsCnt) + 1, Int((Itm - 1) / RwsCnt) + 1), 1) = "=" Then ' We only need to consider the cell style, since individual styles on characters are not possible in a cell with a formula in it
' ....it's not necessary to loop through the characters in each cell when setting the style in the concatenated string from those cells containing formulas
With .Characters(Position, Len(ACel.Value)).Font ' all the characters from the current cell in the final concatenated string
.Name = ACel.Font.Name
.Size = ACel.Font.Size
.Bold = ACel.Font.Bold
.Italic = ACel.Font.Italic
.Underline = ACel.Font.Underline
.Color = ACel.Font.Color
.Strikethrough = ACel.Font.Strikethrough
.Subscript = ACel.Font.Subscript
.Superscript = ACel.Font.Superscript
.TintAndShade = ACel.Font.TintAndShade
.FontStyle = ACel.Font.FontStyle
End With '
Else ' we need to consider all characters in the cell
For ExChr = 1 To Len(ACel.Value) ' We are looping for all the tExt Chraracters in the current cell text
' here in the next With End With section the next character in the final concatenated string is given the styles that it had in the cell it came from
With .Characters(Position + ExChr - 1, 1).Font ' A single character in the final concatenated string
.Name = ACel.Characters(ExChr, 1).Font.Name
.Size = ACel.Characters(ExChr, 1).Font.Size
.Bold = ACel.Characters(ExChr, 1).Font.Bold
.Italic = ACel.Characters(ExChr, 1).Font.Italic
.Underline = ACel.Characters(ExChr, 1).Font.Underline
.Color = ACel.Characters(ExChr, 1).Font.Color
.Strikethrough = ACel.Characters(ExChr, 1).Font.Strikethrough
.Subscript = ACel.Characters(ExChr, 1).Font.Subscript
.Superscript = ACel.Characters(ExChr, 1).Font.Superscript
.TintAndShade = ACel.Characters(ExChr, 1).Font.TintAndShade
.FontStyle = ACel.Characters(ExChr, 1).Font.FontStyle
End With '
Next ExChr
End If
End With
Position = Position + Len(ACel.Value) + 1 ' This takes us to posiion at the end of the current cell text +1 ( +1
Next ACel
Application.ScreenUpdating = True
Rem 0b Put the formulas back
For RwCnt = 1 To RngSel.Rows.Count ' At each row we...._
For ClmCnt = 1 To RngSel.Columns.Count
If Left(arrFormulas(RwCnt, ClmCnt), 1) = "=" Then ' ' case a formula was in cell
Let RngSel.Item(RwCnt, ClmCnt).Formula = arrFormulas(RwCnt, ClmCnt) ' we put the formula back
Else
' we didnt have a formula , so we do nothing to the cell - if we did then we would likely get just one style in the cell - a text with more than one style would revert to one single style throughout
End If
Next ClmCnt
Next RwCnt
End Sub
Coding for this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
and this post
https://eileenslounge.com/viewtopic....279798#p279798
Full version:
Code:Sub Test() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
Dim Indx As Long ' the index of the element to be removed - for this example it can be chosen to be 0 or 1 or 2 or 3 or 4
Let Indx = 4
Dim arr1D() As Variant
Let arr1D() = Array(1, 2, 3, 4, 5)
Dim Joint As String
Let Joint = Join(arr1D(), "|"): Debug.Print Joint ' 1|2|3|4|5 ' - make sure you use a seperator that does not appear in any array element
Let Joint = "|" & Joint & "|": Debug.Print Joint ' |1|2|3|4|5| ' - needed so that I can get at the last and first element also
Dim CrackedJoint As String ' For cracked Joint
' I can use Application.WorksheetFunction.Substitute to pick out specific seperators , so I will replace the one before and after with some word like "Crack"
Let CrackedJoint = Application.WorksheetFunction.Substitute(Joint, "|", "Crack2", Indx + 2): Debug.Print CrackedJoint ' |1|2|3|4|5Crack2 ' ' https://excelfox.com/forum/showthread.php/2230-Built-in-VBA-methods-and-functions-to-alter-the-contents-of-existing-character-strings
Let CrackedJoint = Application.WorksheetFunction.Substitute(CrackedJoint, "|", "Crack1", Indx + 1): Debug.Print CrackedJoint ' |1|2|3|4Crack15Crack2
Dim Crack1 As Long, Crack2 As Long ' The positions of the cracks
Let Crack1 = InStr(1, CrackedJoint, "Crack1", vbBinaryCompare): Debug.Print Crack1 ' 9
Let Crack2 = InStr(1, CrackedJoint, "Crack2", vbBinaryCompare): Debug.Print Crack2 ' 16
Dim LeftBit As String, RightBit As String
Let LeftBit = Left$(CrackedJoint, Crack1 - 1): Debug.Print LeftBit ' |1|2|3|4
Let RightBit = "|" & Mid$(CrackedJoint, Crack2 + 6): Debug.Print RightBit ' |
Dim JointedJoint As String
Let JointedJoint = LeftBit & RightBit: Debug.Print JointedJoint ' |1|2|3|4|
Let JointedJoint = Mid(JointedJoint, 2, Len(JointedJoint) - 2): Debug.Print JointedJoint ' 1|2|3|4
Dim arr1DOut() As String
Let arr1DOut() = Split(JointedJoint, "|", -1, vbBinaryCompare)
' The above array is of element types of String , so we can't assign that to out original Variant type array. We can convert with
Let arr1D() = Application.Index(arr1DOut(), Evaluate("={1,1,1,1}"), Evaluate("={1,2,3,4}")) ' https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376
Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:D)/Column(A:D)"), Evaluate("=Column(A:D)")) ' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028
Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
' or
Let arr1D() = Application.Index(arr1DOut(), 1, 0) '
End Sub
“One liner ( almost ) “ versions
Code:
Sub Test2()
Dim Indx As Long
Let Indx = 4
Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Left$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
End Sub
Sub Test3()
Dim Indx As Long
Let Indx = 1
Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Left$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(arr1D(), "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
End Sub
Function version
Code:Sub testFunction()
Dim arr1D() As Variant: Let arr1D() = Array(1, "2", 3, 4, 5)
Let arr1D() = DeleteItem(arr1D(), 1)
End Sub
Function DeleteItem(ByVal Var As Variant, Indx As Long) As Variant
Let DeleteItem = Application.Index(Split(Mid(Left$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1), 2, Len(Left$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), _
InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "@") - 1) & "|" & Mid$(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), InStr(Application.WorksheetFunction.Substitute(Application.WorksheetFunction.Substitute("|" & Join(Var, "|") & "|", "|", "#", Indx + 2), "|", "@", Indx + 1), "#") + 1)) - 2), "|"), Evaluate("=Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(Var)).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
End Function
Coding for this Thread
http://www.eileenslounge.com/viewtopic.php?f=30&t=35980
and this post
https://eileenslounge.com/viewtopic....de06b5#p279861
Or ....Code:Sub DeleteItemByIndexIn1DArraySHG1() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980&p=279809#p279809 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
Dim Indx As Long '
Let Indx = 1 ' 1 is for deleting the first element
Dim arr1D() As Variant
Let arr1D() = Array(1, 2, 3, 4, 5)
Dim Joint As String
Let Joint = Join(arr1D(), ","): Debug.Print Joint ' 1,2,3,4,5 ' - make sure you use a seperator that does not appear in any array element
Dim Pos1 As Long, Pos2 As Long
Let Pos1 = Evaluate("=Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))")
Debug.Print Pos1 ' 1
Let Pos2 = Evaluate("=Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))")
Debug.Print Pos2 ' 3
Dim LeftBit As String, RightBit As String
Let LeftBit = Left$("," & Joint, Pos1 - 1): Debug.Print LeftBit ' nothing there '
Let LeftBit = Evaluate("=Left(""," & Joint & """, " & Pos1 - 1 & ")"): Debug.Print LeftBit ' nothing there
Let RightBit = "," & Mid$("," & Joint & ",", Pos2 + 1): Debug.Print RightBit ' ,2,3,4,5,
' The MID spreadsheet function is less helpful since it must have the third argument ( in VBA MID the third length argument is optional
Let RightBit = "," & Right$("," & Joint & ",", Len(Joint) - (Pos2 - 2)): Debug.Print RightBit ' ,2,3,4,5, ' we don't want to take off the , and Joint is one less than Joint & "," so we take off in total 2 less
Let RightBit = Evaluate("="",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print RightBit ' ,2,3,4,5, '
Rem Joining the two and trimming odff the leading and trailing seperators
Dim JointedJoint As String
'Let JointedJoint = LeftBit & RightBit: Debug.Print JointedJoint ' ,2,3,4,5,
'Let JointedJoint = Evaluate("=""" & LeftBit & RightBit & """"): Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=" & """" & LeftBit & RightBit & """"): Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=" & """" & LeftBit & ",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=Left(""," & Joint & """, " & Pos1 - 1 & ")&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (" & Pos2 - 2 & "))")
Debug.Print JointedJoint ' ,2,3,4,5,
Let JointedJoint = Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")
Debug.Print JointedJoint ' ,2,3,4,5,
'Let JointedJoint = Mid(JointedJoint, 2, Len(JointedJoint) - 2): Debug.Print JointedJoint ' 2,3,4,5
'Debug.Print JointedJoint ' 2,3,4,5
'Let JointedJoint = Evaluate("=Mid(Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2)),2,Len(Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))))") ' Evaluate string has 355 characters so it wont work
'Debug.Print JointedJoint
Let JointedJoint = Mid(Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Joint & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Joint & ","", Len(""" & Joint & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
Debug.Print JointedJoint ' 2,3,4,5
' replace Joint with Join(arr1D(), ",")
Let JointedJoint = Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
Debug.Print JointedJoint ' 2,3,4,5
' Get the string array back
Dim arr1DOut() As String
Let arr1DOut() = Split(JointedJoint, ",", -1, vbBinaryCompare): Let arr1DOut() = Split(JointedJoint, ",")
Let arr1DOut() = Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ",")
' The spilt has returned string Elements, so we can't directly assign to the original array
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("={1,1,1,1}"), Evaluate("={1,2,3,4}")) ' https://www.excelforum.com/tips-and-tutorials/758402-vba-working-with-areas-within-2d-arrays.html#post5408376
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:D)/Column(A:D)"), Evaluate("=Column(A:D)")) ' https://www.excelforum.com/excel-programming-vba-macros/1328703-copy-1-dim-array-to-and-2-dim-array.html#post5410028
' Let arr1D() = Application.Index(arr1DOut(), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")/Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")"), Evaluate("=Column(A:" & Split(Cells(1, UBound(arr1D())).Address, "$", -1, vbBinaryCompare)(1) & ")")) '
' or
' Let arr1D() = Application.Index(arr1DOut(), 1, 0) ' https://excelfox.com/forum/showthread.php/1111-VBA-Trick-of-the-Week-Slicing-an-Array-Without-Loop-%c3%a2%e2%82%ac%e2%80%9c-Application-Index
Let arr1D() = Application.Index(Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ","), 1, 0) ' Full workings: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
End Sub
Some explanations in next postCode:Sub DeleteItemByIndexIn1DArraySHG2() ' http://www.eileenslounge.com/viewtopic.php?f=30&t=35980&p=279809#p279809 https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
Dim Indx As Long '
Let Indx = 1 ' 1 is for deleting the first element
Dim arr1D() As Variant: Let arr1D() = Array(1, 2, 3, 4, 5)
Let arr1D() = Application.Index(Split(Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2), ","), 1, 0) ' Full workings: https://excelfox.com/forum/showthread.php/2345-Appendix-Thread-(-Codes-for-other-Threads-HTML-Tables-etc-)?p=15218&viewfull=1#post15218
End Sub
( In this example, Indx, is the Index number of the element that we want to remove starting from 1 – For the first element Indx must be given as 1
In Words , this is how the main code line works…( taking the example of wanting to remove the first element
My 1 D array , for example , {1,2,3,4,5} , is turned into a single text string, “1,2,3,4,5”. ( The separating thing, a comma in this case, is arbitrary. You should choose some character that is not likely to appear in any of your data.)
The next thing to do is add additional leading and trailing separating things ( commas in this example ) , so in the example it would then look like “,1,2,3,4,5,”
Now we use this sort of bit a lot.. Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx +1 & "))
Substitute is used to change the comma before the element you want to some other arbitrary separating thing.
So lets say we used a | and are wanting the first element ( Indx=1 ) removed. We then would have like
“|1,2,3,4,5,”
We then do a Find to get the position of that |
In other words,
The Substitute gives us this "|1,2,3,4,5,"
The Find looks for the | and gives us 1
Substitute is used again to change the comma after the element you want to some other arbitrary separating thing.
So lets say we used a | again. ( we are still wanting the first element) We then would have like
“,1|2,3,4,5,”
We then do a Find to get the position of that |
In other words,
The Substitute gives us this ",1|2,3,4,5,"
The Find looks for that | and gives us 3
Here is the last bit in close to the final code line:
So we now know where the start and the end is of the element that we want to remove areCode:Mid(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))"), 2, Len(Evaluate("=Left(""," & Join(arr1D(), ",") & """, Find(""|"", Substitute(""," & Join(arr1D(), ",") & """, "","", ""|"", " & Indx & "))-1)&"",""&Right(""," & Join(arr1D(), ",") & ","", Len(""" & Join(arr1D(), ",") & """) - (Find(""|"", Substitute(""," & Join(arr1D(), ",") & ","", "","", ""|"", " & Indx + 1 & "))-2))")) - 2)
We can use this information to determine the string before, and to determine the string after, the element that we want to remove.
So we put those two strings together and that gives us the original string without the element that we want to remove.
Finally we Split that text back into an array
( Once again we will have all string elements out, regardless of what element types we have in our original array )
post for later use..
http://i.imgur.com/dol9tfQ.jpg
http://i.imgur.com/Ucpj9pZ.jpg
http://i.imgur.com/mtLzChH.jpg
http://i.imgur.com/N2PbR0C.jpg
http://i.imgur.com/Nzfnk90.jpg
http://i.imgur.com/rnYpqNh.jpg
http://i.imgur.com/RODuXQl.jpg
http://i.imgur.com/zpWglC9.jpg
Hello
I tried it , second one, http://i.imgur.com/wL6hN1c.jpg
It did not work
http://i.imgur.com/Z7bl5cc.jpg
http://i.imgur.com/NG2ICxa.jpg
http://i.imgur.com/EpDQOXB.jpg
Alan
post for later use-
post for later use
post for later use