Convert 2 dimensional array to one dimensional (without Looping)

Question

I found this worked well for an Excel Range, where the result would be array(n) notation instead of array(1, n)

Result = Application.Transpose(Application.Transpose(Worksheets(kSheet).Range("Y20:AC20")))

However I have a result from .getrows which is array (n,0) notation. Can this be converted to arry(n) notation similar to above ?

Answer 1

You have discovered an anomaly (bug?) and, with a very limited explanation of that anomaly, ask how to extend its availability. That is why no one can understand your question.

Explanation of the anomaly

If you load a single cell into a variable of type Variant that Variant will hold a single value with its type defined by the cell.

If you load a column into a variable of type Variant that Variant will hold an array with dimensions (1 To NumRows, 1 To 1) with each element having its type defined by the corresponding cell.

If you load a row into a variable of type Variant that Variant will hold an array with dimensions (1 To 1, 1 To NumCols).

If you load a rectangle into a variable of type Variant that Variant will hold an array with dimensions (1 To NumRows, 1 To NumCols).

If you do not like the sequence of the dimensions, you can use WorksheetFunction.Transpose to swap them.

If you use WorksheetFunction.Transpose twice, I would expect the array would be restored to its original state. I cannot find any documentation that suggests otherwise.

You have discovered that if you load a row and then use WorksheetFunction.Transpose twice, the first dimension is removed. That is, the dimensions are changed from (1 To 1, 1 To NumCols) to (1 To NumCols).

However, if you load a column and then use WorksheetFunction.Transpose twice, the dimensions are restored to their original state.

My solution

I consider the effect of WorksheetFunction.Transpose on a row to be a bug. The problem with relying on a bug is that it might be fixed in a future version of Excel or might not exist in an earlier version.

Another problem I have discovered recently is that some, perhaps all, worksheet functions are slow. I doubt they are slow when used within a worksheet formula so assume this is an overhead with the call from VBA.

The macro Timings, below, demonstrates this effect. The timings are from my 2.1 GHz laptop; your timings may be different but I would expect the relationships to be unchanged. Note also that the timings I show are averages from 10 runs of the macro.

I have filled “A1:T10000” of worksheet “Sheet1” with values. The macro Timings loads data from the worksheet and manipulates to get these timings:

Secs  Action
.165  Load (1 To 10000, 1 To 20)
.806  Worksheet Transpose to (1 To 20, 1 To 10000)
.220  Worksheet Transpose to (1 To 10000, 1 To 20)
.118  TransposeVar Transpose to (1 To 20, 1 To 10000)
.181  TransposeVar Transpose to (1 To 10000, 1 To 20)

.031  Load (1 To 20, 1 To 1)
.039  Transpose twice (1 To 20, 1 To 1)
.000  Load (1 To 1, 1 To 20)
.000  Transpose twice (1 To 20)

I do not know why transposing one way is quicker than transposing the other way. However, you can see that WorksheetFunction.Transpose takes three times as long as my VBA routine. If you are only loading one range, this is unimportant. However, if you are loading many ranges that extra time will become important.

The second set of rows shows the effect of loading a column and transposing it twice and the effect of loading a row and transposing it twice. The final row shows the anomaly you discovered: the first dimension has been removed by the double transpose.

The macro Test demonstrates the use of function RemoveUpperEqLowerDim. You ask how to extend the use of the anomaly; I do not believe this is possible. Function RemoveUpperEqLowerDim may use looping but it is quicker that WorksheetFunction.Transpose and works with both row and column ranges.

Option Explicit
Sub Timings()

  Dim CellValue1 As Variant
  Dim CellValue2 As Variant
  Dim CellValue3 As Variant
  Dim ColCrnt As Long
  Dim RowCrnt As Long
  Dim TimeStart As Single

  Debug.Print "Secs  Action"

  ' Load rectangle
  TimeStart = Timer
  CellValue1 = Worksheets("Sheet1").Range("A1:T10000")
  Debug.Print Format(Timer - TimeStart, ".000") & "  Load " & ArrayBounds(CellValue1)

  ' Load rectangle
  TimeStart = Timer
  CellValue2 = Worksheets("Sheet1").Range("A1:T10000")
  Debug.Print Format(Timer - TimeStart, ".000") & "  Load " & ArrayBounds(CellValue2)

  ' Transpose rectangle using WorksheetFunction.Transpose
  TimeStart = Timer
  CellValue2 = WorksheetFunction.Transpose(CellValue2)
  Debug.Print Format(Timer - TimeStart, ".000") & "  Worksheet Transpose to " & _
                                                            ArrayBounds(CellValue2)

  ' Transpose rectangle using WorksheetFunction.Transpose back to original state
  TimeStart = Timer
  CellValue2 = WorksheetFunction.Transpose(CellValue2)
  Debug.Print Format(Timer - TimeStart, ".000") & "  Worksheet Transpose to " & _
                                                            ArrayBounds(CellValue2)

  ' Check twice transposed array matches copy of original
  For RowCrnt = LBound(CellValue2, 1) To UBound(CellValue2, 1)
    For ColCrnt = LBound(CellValue2, 2) To UBound(CellValue2, 2)
      If CellValue1(RowCrnt, ColCrnt) <> CellValue1(RowCrnt, ColCrnt) Then
        Debug.Assert False
      End If
    Next
  Next

  ' Transpose rectangle using VBA function TransposeVar
  TimeStart = Timer
  Call TransposeVar(CellValue3, CellValue2)
  Debug.Print Format(Timer - TimeStart, ".000") & "  TransposeVar Transpose to " & _
                                                              ArrayBounds(CellValue3)

  ' Transpose rectangle using VBA function TransposeVar  back to original state
  TimeStart = Timer
  Call TransposeVar(CellValue2, CellValue3)
  Debug.Print Format(Timer - TimeStart, ".000") & "  TransposeVar Transpose to " & _
                                                              ArrayBounds(CellValue2)

  ' Check twice transposed array matches copy of original
  For RowCrnt = LBound(CellValue2, 1) To UBound(CellValue2, 1)
    For ColCrnt = LBound(CellValue2, 2) To UBound(CellValue2, 2)
      If CellValue1(RowCrnt, ColCrnt) <> CellValue1(RowCrnt, ColCrnt) Then
        Debug.Assert False
      End If
    Next
  Next

  ' Load column
  TimeStart = Timer
  CellValue1 = Worksheets("Sheet1").Range("A1:A20")
  Debug.Print Format(Timer - TimeStart, ".000") & "  Load " & ArrayBounds(CellValue1)

  ' Transpose column twice with WorksheetFunction.Transpose
  TimeStart = Timer
  CellValue2 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Worksheets("Sheet1").Range("A1:A20")))
  Debug.Print Format(Timer - TimeStart, ".000") & "  Transpose twice " & ArrayBounds(CellValue2)

  ' Load row
  TimeStart = Timer
  CellValue1 = Worksheets("Sheet1").Range("A20:T20")
  Debug.Print Format(Timer - TimeStart, ".000") & "  Load " & ArrayBounds(CellValue1)

  ' Transpose row twice with WorksheetFunction.Transpose. Column dimension is removed.
  TimeStart = Timer
  CellValue2 = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Worksheets("Sheet1").Range("A20:T20")))
  Debug.Print Format(Timer - TimeStart, ".000") & "  Transpose twice " & ArrayBounds(CellValue2)

End Sub
Sub Test()

  Dim CellValue1 As Variant
  Dim CellValue2 As Variant
  Dim InxCrnt As Long

  ' Load column
  CellValue1 = Worksheets("Sheet1").Range("A1:A20")
  Debug.Print "  CellValue1 " & ArrayBounds(CellValue1)
  ' Remove row dimension
  CellValue2 = RemoveUpperEqLowerDim(CellValue1)
  Debug.Print "  CellValue2 " & ArrayBounds(CellValue2)

  ' Check values match
  For InxCrnt = LBound(CellValue1, 1) To UBound(CellValue1, 1)
    If CellValue1(InxCrnt, 1) <> CellValue2(InxCrnt) Then
      Debug.Assert False
    End If
  Next

  ' Load row
  CellValue1 = Worksheets("Sheet1").Range("A20:T20")
  Debug.Print "  CellValue1 " & ArrayBounds(CellValue1)
  ' Remove column dimension
  CellValue2 = RemoveUpperEqLowerDim(CellValue1)
  Debug.Print "  CellValue2 " & ArrayBounds(CellValue2)

  ' Check values match
  For InxCrnt = LBound(CellValue1, 2) To UBound(CellValue1, 2)
    If CellValue1(1, InxCrnt) <> CellValue2(InxCrnt) Then
      Debug.Assert False
    End If
  Next

  Dim Inx1Crnt As Long
  Dim Inx2Crnt As Long

  ' Load rectangle
  CellValue1 = Worksheets("Sheet1").Range("A1:T30")
  Debug.Print "  CellValue1 " & ArrayBounds(CellValue1)
  ' CellValue2 becomes copy of CellValue1
  CellValue2 = RemoveUpperEqLowerDim(CellValue1)
  Debug.Print "  CellValue2 " & ArrayBounds(CellValue2)

  ' Check values match
  For Inx1Crnt = LBound(CellValue1, 1) To UBound(CellValue1, 1)
    For Inx2Crnt = LBound(CellValue1, 2) To UBound(CellValue1, 2)
      If CellValue1(Inx1Crnt, Inx2Crnt) <> CellValue2(Inx1Crnt, Inx2Crnt) Then
        Debug.Assert False
      End If
    Next
  Next

End Sub
Function ArrayBounds(ParamArray Tgt() As Variant) As String

  Dim InxDimCrnt As Long
  Dim InxDimMax As Long

  InxDimMax = NumDim(Tgt(0))
  ArrayBounds = "("
  For InxDimCrnt = 1 To InxDimMax
    If InxDimCrnt > 1 Then
      ArrayBounds = ArrayBounds & ", "
    End If
    ArrayBounds = ArrayBounds & LBound(Tgt(0), InxDimCrnt) & " To " & UBound(Tgt(0), InxDimCrnt)
  Next
  ArrayBounds = ArrayBounds & ")"

End Function
Public Function NumDim(ParamArray TestArray() As Variant) As Integer

  ' Returns the number of dimensions of TestArray.

  ' If there is an official way of determining the number of dimensions, I cannot find it.

  ' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
  ' By trapping that failure it can determine the last test that did not fail.

  ' Coded June 2010. Documentation added July 2010.

  ' *  TestArray() is a ParamArray because it allows the passing of arrays of any type.
  ' *  The array to be tested in not TestArray but TestArray(LBound(TestArray)).
  ' *  The routine does not validate that TestArray(LBound(TestArray)) is an array.  If
  '    it is not an array, the routine return 0.
  ' *  The routine does not check for more than one parameter.  If the call was
  '    NumDim(MyArray1, MyArray2), it would ignore MyArray2.

  Dim TestDim                   As Integer
  Dim TestResult                As Integer

  On Error GoTo Finish

  TestDim = 1
  Do While True
    TestResult = LBound(TestArray(LBound(TestArray)), TestDim)
    TestDim = TestDim + 1
  Loop

Finish:

  NumDim = TestDim - 1

End Function
Function RemoveUpperEqLowerDim(Var As Variant) As Variant

  ' * Var must be a variant redimensioned to hold a 2D array
  ' * If the dimensions are (M To N, P To P) or (P to P, M to N), a variant
  '   will be returned with the dimension with equal lower and upper bounds
  '   removed.  That is the returned array has dimensions (M to N).
  ' * If neither dimension has equal lower and upper bounds, the original
  '   array will be returned.

  Dim NewVar As Variant
  Dim InxCrnt As Long

  If NumDim(Var) <> 2 Then
    ' There is no code to handle this situation
    Debug.Assert False
    RemoveUpperEqLowerDim = Var
    Exit Function
  End If

  If LBound(Var, 1) = UBound(Var, 1) Then
    ' The first dimension has equal bounds
    ReDim NewVar(LBound(Var, 2) To UBound(Var, 2))
    For InxCrnt = LBound(Var, 2) To UBound(Var, 2)
      NewVar(InxCrnt) = Var(LBound(Var, 2), InxCrnt)
    Next
    RemoveUpperEqLowerDim = NewVar
  ElseIf LBound(Var, 2) = UBound(Var, 2) Then
    ' The second dimension has equal bounds
    ReDim NewVar(LBound(Var, 1) To UBound(Var, 1))
    For InxCrnt = LBound(Var, 1) To UBound(Var, 1)
      NewVar(InxCrnt) = Var(InxCrnt, LBound(Var, 1))
    Next
    RemoveUpperEqLowerDim = NewVar
  Else
    ' Neither dimension has equal bounds
    RemoveUpperEqLowerDim = Var
  End If

End Function
Sub TransposeVar(ParamArray Tgt() As Variant)

  ' * Example call:  Call Transpose(Destination, Source)
  ' * Source must be a 2D array or a variant holding a 2D array.
  ' * Destination must be a variant.
  ' * On exit, Destination will contain the values from Source but with the
  '   dimensions reversed.

  ' * Tgt(0)  Destination
  ' * Tgt(1)  Source

  Dim ColCrnt As Long
  Dim RowCrnt As Long
  Dim Test() As String

  ' This call necessary because the following gives a syntax error:
  '    ReDim Tgt(0)(LBound(Tgt(1), 2) To UBound(Tgt(1), 2), _
  '                 LBound(Tgt(1), 1) To UBound(Tgt(1), 1))
  Call ReDimVar(Tgt(0), Tgt(1))

  For RowCrnt = LBound(Tgt(1), 1) To UBound(Tgt(1), 1)
    For ColCrnt = LBound(Tgt(1), 2) To UBound(Tgt(1), 2)
      Tgt(0)(ColCrnt, RowCrnt) = Tgt(1)(RowCrnt, ColCrnt)
    Next
  Next

End Sub
Sub ReDimVar(Destination As Variant, ParamArray Source() As Variant)

  ' * Source(0) must be a 2D array or a variant holding a 2D array
  ' * Redim Destination to match Source(0) but with the dimensions reversed

  ReDim Destination(LBound(Source(0), 2) To UBound(Source(0), 2), _
                    LBound(Source(0), 1) To UBound(Source(0), 1))

End Sub