Code:
Function Fu_Rick(ByRef arrIn() As Variant, ByVal RowToDelete As Long) As Variant
10 ' use "neat magic" code line arrOut() = Application.Index(arrIn(), rwsT(), clms())
20 ' So we have directly the Input Array, arrIn(). For clms(), do some extra stuff to get a column letter ( usiing the Split Address Method ) then column indices diectly from Spreadsheet column() Function. Rows from joinig the Row indicies above and below the row to be deleted
30 Dim Cols As String: Cols = "A:" & Split(Columns(UBound(arrIn(), 2) - LBound(arrIn(), 2) + 1).Address(, 0), ":")(0)
40 ' Fu_Rick = Application.Index(arrIn(), Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")"))))), Evaluate("COLUMN(" & Cols & ")"))
50
60 ' clms() = { 1, 2, 3, 4, 5 }
61 'clms() Rick Evaluate("COLUMN(" & "A:" & Split(Columns(UBound(arrIn(), 2) - LBound(arrIn(), 2) + 1).Address(, 0), ":")(0) & ")")
70 ' Start point is last column in Output Array using.. Split Address technique http://www.excelforum.com/development-testing-forum/1101544-thread-post-appendix-no-reply-needed-please-do-not-delete-thanks-4.html#post4213969
80 Dim larrClm As Long: Let larrClm = ((UBound(arrIn(), 2) - LBound(arrIn(), 2)) + 1) ' For our Output Array ( base 1 ) staring at 1 - not yet pinned to a Top left Output Range cell the ( ( stop "column" - start "column" ) + 1 ) gives "last" "column"
90 Dim AdrsRel As String: Let AdrsRel = Columns(larrClm).Address(ColumnAbsolute:=False) 'False absolute Address gives no $ prefix and format like "E:E" (true Relative Address) , so split by ":" and then either (0) or (1) returned arrAddressSplit() Element will do for the letter..
100 Dim arrAddressSplit() As String
110 Let arrAddressSplit() = VBA.Split(AdrsRel, ":", 2, vbTextCompare) 'Splits into like ("E", "E") for no or -1 second argument.. Here 2 gives just the 2 you would get E, and E - ... http://www.mrexcel.com/forum/general-excel-discussion-other-questions/929381-visual-basic-applications-split-function-third-argument-refers-maximum-outputs-%93when-splitting-stops-%94.html
120 Dim clmLtr As String
130 Let clmLtr = arrAddressSplit(0) 'Returns first element "along" in 1 Dimensional "Psuedo Horizontal" Array ( Elements for 1 Dimensional Array are by default 0,1, 2, 3 ....etc )
140 ' Now use spreadsheet column function , column(A:E"), to get a {1, 2, 3, 4, 5} Array
150 Dim clms() As Variant: Let clms() = Evaluate("column(A:" & clmLtr & ")")
160 'rwsT() Rick Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")")))))
170 'Final required row Indicies, with a missing indicie, as 2 strings ( Hard Copy )
180 Dim strRwsDBelow As String, strRwsDAbove As String, strrwsD As String
190 Let strRwsDBelow = "1 2 3 4": Let strRwsDAbove = "6 7 8 9 10"
200 Let strrwsD = "1 2 3 4" & " " & "6 7 8 9 10"
210 Let strrwsD = strRwsDBelow & " " & strRwsDAbove
220
230
240 'Get row indicies conveniently from Row Function - ( correct "orintation" to use in "neat magic" code line, but wrong "orientation" to use Join Function {1; 2; 3; 4} and {6; 7; 8; 9; 10} )
250 Dim arr_2D1rowBelow() As Variant, arr_2D1rowAbove() As Variant
260 Let arr_2D1rowBelow() = Evaluate("Row(1:" & (RowToDelete - 1) & ")") ' 1 To 4, 1 To 1 {1; 2; 3; 4} Array
270 Let arr_2D1rowAbove() = Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")") ' 1 To 5, 1 To 1 {6; 7; 8; 9; 10} Array
280 'Get sequential below and above row strings.... transpose back again! so Join will work, dear oh dear.....
290 Let strRwsDBelow = Join(Evaluate("transpose(Row(1:" & (RowToDelete - 1) & "))"), " ") 'Join must have eindimensional Array, as given by transpose working on a 2D 1 column Array
300 Let strRwsDBelow = Join(Application.Transpose((Evaluate("Row(1:" & (RowToDelete - 1) & ")"))), " ") ' "1 2 3 4"
310 Let strRwsDBelow = Join(Application.Transpose((arr_2D1rowBelow())), " ") ' "1 2 3 4"
320 Let strRwsDAbove = Join(Application.Transpose((arr_2D1rowAbove())), " ") ' "6 7 8 9 10"
330 'Final required row Indicies, with a missing indicie, as a string
340 Let strrwsD = strRwsDBelow & " " & strRwsDAbove
350
360 'Split Final String by " " to get 1 1D "Pseudo Horizontal" Array
370 Dim rws() As String: Let rws() = VBA.Split(strrwsD, " ") ' 1 D Array
380 'final Transposed Array for "magic neat" code line
390 Dim rwsT() As Variant: Let rwsT() = Application.Transpose(rws()) ' 2 D 1 "column" Array
400
440 'Output Array
450 Dim arrOut() As Variant
460 Let arrOut() = Application.Index(arrIn(), rwsT(), clms())
470
480 Let Fu_Rick = arrOut()
490 'Or
Fu_Rick = Application.Index(arrIn(), Application.Transpose(Split(Join(Application.Transpose(Evaluate("Row(1:" & (RowToDelete - 1) & ")"))) & " " & Join(Application.Transpose(Evaluate("Row(" & (RowToDelete + 1) & ":" & UBound(arrIn()) & ")"))))), Evaluate("COLUMN(" & "A:" & Split(Columns(UBound(arrIn(), 2) - LBound(arrIn(), 2) + 1).Address(, 0), ":")(0) & ")"))
End Function
Bookmarks