将二维数组转换为一维数组(不进行循环)

Question

我发现这对于Excel范围很好，结果将是数组( n)表示法而不是数组(1，n)。

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

但是，我有一个来自.getrows的结果，即数组(n,0)表示法。这能转换成类似于上面的arry(n)符号吗？

Answer 1

你发现了一个异常(窃听器？)而且，对于这种异常现象的解释非常有限，请询问如何扩展它的可用性。所以没人能理解你的问题。

对异常的解释

如果将单个单元格加载到类型变量的变量中，该变量将保存由单元格定义的单个值及其类型。

如果将列加载到变量类型的变量中，则该变量将持有一个数组，该数组的维度为(1 To NumRows, 1 To 1)，每个元素的类型都由相应的单元格定义。

如果将一行加载到变量类型的变量中，则该变量将保存一个维度为(1 To 1, 1 To NumCols)的数组。

如果将矩形加载到变量类型的变量中，则该变量将保存一个维度为(1 To NumRows, 1 To NumCols)的数组。

如果您不喜欢维度的顺序，可以使用WorksheetFunction.Transpose来交换它们。

如果您两次使用WorksheetFunction.Transpose，我希望数组将恢复到原来的状态。我找不到任何文件表明不是这样。

您已经发现，如果加载一行，然后使用WorksheetFunction.Transpose两次，则第一个维度将被移除。也就是说，维度从(1 To 1, 1 To NumCols)更改为(1 To NumCols)。

但是，如果加载一个列，然后两次使用WorksheetFunction.Transpose，则维度将恢复到原来的状态。

我的解决方案

我认为WorksheetFunction.Transpose对一行的影响是一个bug。依赖bug的问题是，它可能在Excel的未来版本中修复，或者在早期版本中不存在。

我最近发现的另一个问题是，有些(也许全部)工作表函数是缓慢的。我怀疑它们在工作表公式中使用时是否慢，所以假设这是来自VBA调用的开销。

下面的宏Timings演示了这种效果。时间来自我的2.1 GHz笔记本电脑；您的时间可能不一样，但我希望关系不会改变。还请注意，我显示的时间是宏运行10次的平均值。

我已经用值填充了工作表“Sheet1”的“A1:T 10000”。宏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)

我不知道为什么转一条路比转另一条路更快。但是，您可以看到，WorksheetFunction.Transpose花费的时间是我的VBA例程的三倍。如果您只加载一个范围，这是不重要的。但是，如果您正在加载许多范围，则额外的时间将变得非常重要。

第二组行显示了加载一列并将其转置两次的效果，以及加载一行和转置它两次的效果。最后一行显示了您发现的异常:第一维度已被双转置移除。

宏Test演示了函数RemoveUpperEqLowerDim的用法。您会问如何扩展异常的使用；我认为这是不可能的。函数RemoveUpperEqLowerDim可以使用循环，但是WorksheetFunction.Transpose和行范围和列范围都可以更快地工作。

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