如何在VBA中向现有矩阵添加计数器列？

Question

如何在 VBA 中使用第一个“列”中的计数器值获取新矩阵。 假设我们有一个 VBA 矩阵，其中包含我们从单元格中获取的值。 A1单元格的值只是“A1”。

Dim matrix As Variant
matrix = Range("A1:C5").value

输入矩阵：

+----+----+----+
| A1 | B1 | C1 |
+----+----+----+
| A2 | B2 | C2 |
+----+----+----+
| A3 | B3 | C3 |
+----+----+----+
| A4 | B4 | C4 |
+----+----+----+
| A5 | B5 | C5 |
+----+----+----+

我想在 VBA 矩阵的第一列中使用计数器值获取新矩阵。

以下是想要的结果：

+----+----+----+----+
|  1 | A1 | B1 | C1 |
+----+----+----+----+
|  2 | A2 | B2 | C2 |
+----+----+----+----+
|  3 | A3 | B3 | C3 |
+----+----+----+----+
|  4 | A4 | B4 | C4 |
+----+----+----+----+
|  5 | A5 | B5 | C5 |
+----+----+----+----+

一种方法是循环。 有没有其他更优雅的方式来做到这一点？ 我们在这里处理大型数据集，所以请注意性能。

Answer 1

如果您主要关注性能，那么使用Redim Preserve在末尾添加一个新列，并使用 OS API 直接在内存中移动每一列：

Private Declare PtrSafe Sub MemCpy Lib "kernel32" Alias "RtlMoveMemory" ( _
  ByRef dst As Any, ByRef src As Any, ByVal size As LongPtr)

Private Declare PtrSafe Sub MemClr Lib "kernel32" Alias "RtlZeroMemory" ( _
  ByRef src As Any, ByVal size As LongPtr)


Sub AddIndexColumn()
  Dim arr(), r&, c&
  arr = [A1:F1000000].Value

  ' add a column at the end
  ReDim Preserve arr(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2) + 1)

  ' shift the columns by 1 to the right
  For c = UBound(arr, 2) - 1 To LBound(arr, 2) Step -1
    MemCpy arr(LBound(arr), c + 1), arr(LBound(arr), c), (UBound(arr) - LBound(arr) + 1) * 16
  Next
  MemClr arr(LBound(arr), LBound(arr, 2)), (UBound(arr) - LBound(arr) + 1) * 16

  ' add an index in the first column
  For r = LBound(arr) To UBound(arr)
    arr(r, LBound(arr, 2)) = r
  Next

End Sub

Answer 2

方法一

此方法将单元格插入到范围的左侧并设置新的单元格公式来计算计数器=ROWS($A$1:$A5) 。 注意：此模式也用于计算运行总数。

用法

InsertCounter Worksheets("Sheet1").Range("A1:C5")

Sub InsertCounter(Target As Range)
    Dim counterCells As Range
    Target.Columns(1).Insert Shift:=xlToRight
    Set counterCells = Target.Columns(1).Offset(0, -1)
    counterCells.Formula = "=Rows(" & counterCells.Cells(1, 1).Address(True, True) & ":" & counterCells.Cells(1, 1).Address(False, True) & ")"
End Sub

方法二

此方法将范围的值复制到一个数组中，创建一个具有 1 个额外列的新数组，然后将数据和计数器复制到新数组中。 此方法的不同之处在于它不插入任何单元格。

用法

AddCounterToMatrix Worksheets("Sheet1").Range("A1:C5")

Sub AddCounterToMatrix(Target As Range)
    Dim x As Long, y As Long
    Dim Matrix1 As Variant, NewMatrix1 As Variant
    Matrix1 = Target.Value

    ReDim NewMatrix1(LBound(Matrix1) To UBound(Matrix1), LBound(Matrix1, 2) To UBound(Matrix1, 2) + 1)

    For x = LBound(Matrix1) To UBound(Matrix1)
        NewMatrix1(x, 1) = x - LBound(Matrix1) + 1
        For y = LBound(Matrix1, 2) To UBound(Matrix1, 2)
            NewMatrix1(x, y + 1) = Matrix1(x, y)
        Next
    Next

    Target.Resize(UBound(NewMatrix1) - LBound(Matrix1) + 1, UBound(NewMatrix1, 2) - LBound(NewMatrix1, 2) + 1).Value = NewMatrix1

End Sub

Answer 3

使用 Dynamic 变体很快。

Sub test()
    Dim matrix As Variant, newMatrix()
    Dim i As Long, n As Long, c As Long, j As Long
    matrix = Range("A1:C5").Value
    n = UBound(matrix, 1)
    c = UBound(matrix, 2)
    ReDim newMatrix(1 To n, 1 To c + 1)
    For i = 1 To n
        newMatrix(i, 1) = i
        For j = 2 To c + 1
            newMatrix(i, j) = matrix(i, j - 1)
        Next j
    Next i
    Range("a1").Resize(n, c + 1) = newMatrix
End Sub

Answer 4

基于 excel 的解决方案适合你吗？

Columns("A:A").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1") = "1"
Range("A2") = "2"
Range("A1:A2").Select
Selection.AutoFill Destination:=Range("A1:A5")

Dim matrix As Variant
matrix = Range("A1:D5").Value

Answer 5

为什么不通过插入一个临时列并在数组的第一列中完成其余工作来在家庭补救措施和纯数组脚本之间进行折衷。

代码

Option Explicit

Public Sub test_CounterCol2()
Dim matrix As Variant, newMatrix()
Dim i As Long, n As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("CounterCol")    ' <== user defined sheet
' a) insert column temporarily]
  ws.Columns("A:A").Insert Shift:=xlToRight
' b) get values
  matrix = ws.Range("A1:D5").value
' c) only loop within array counter column
  n = UBound(matrix, 1)
  For i = 1 To n
        matrix(i, 1) = i
  Next i
' d) delete temporary insertion
  ws.Columns("A:A").Delete (xlShiftToLeft)

End Sub

附加说明：也许您可以通过 API (CopyMemory) 找到一些东西。