vba - 根据最后一行生成一个直接的数字序列

Question

lrow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
For p = 1 To lrow
    period(p) = p
Next p
With ws2
    lrow2 = .Cells(.Rows.Count, 1).End(xlUp).Row
    .Range("A1").Offset(lrow2, 1).Resize(lrow).Value = Application.Transpose(period)
    ws1.Range(ws1.Cells(5, 1), ws1.Cells(lrow, 1)).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 2)
End With

如您所见，我正在尝试将数据列从一张纸复制到另一张纸，效果很好。但是如果注意到我在 p 中生成一个从 1 到 lastrow 的序列，这对我来说看起来非常愚蠢，因为我正在使用循环，并且我确信还有另一种方法来生成它并将其复制到另一张纸。我怎样才能固定这个，因为从代码中删除 application.transpose(period) 行可以使其运行时间缩短一半。如果有人可以提供建议，我请求一种更快的方法。谢谢。

例如

  Sheet1                           Sheet2
  John                          1  John
  Jim                           2  Jim
  Jack                          3  Jack

我正在从 Sheet1 生成 Sheet2，数字和名称位于不同的列中。我可以像代码中那样使用副本作为名称，但我需要自己生成数字。

Answer 1

我对此很好奇，所以我测量了 4 个选项:

Max itms:    65,000
  Transpose: 0.0586 sec
  Formula:   0.0938 sec
  Fill down: 0.0273 sec <<<
  2D Array:  0.0547 sec

Max itms:    1,000,000
  Formula:   0.4688 sec
  Fill down: 0.2305 sec <<<
  2D Array:  0.6992 sec

.

测试代码:

Public Sub idSequence()
    Const MAXR As Long = 1000000
    Const CRx2 As String = " sec" & vbCrLf  ' & vbCrLf
    Const NFRM As String = "#,##0.0000"
    Dim arr As Variant, i As Long, msg As String, t As Double

    If MAXR <= 65000 Then    'Upper Limit: 65,000
        t = Timer
        ReDim arr(1 To MAXR)
        For i = 1 To MAXR
            arr(i) = i
        Next
        Range("A1:A" & MAXR).Formula = Application.Transpose(arr)
        msg = msg & "Transp: " & vbTab & Format(Timer - t, NFRM) & CRx2
    End If

    t = Timer
    Range("B1:B" & MAXR).Formula = "=Row()"
    msg = msg & "Formula:" & vbTab & Format(Timer - t, NFRM) & CRx2

    t = Timer
    Range("C1") = 1
    Range("C1:C" & MAXR).DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1
    msg = msg & "Fill down:" & vbTab & Format(Timer - t, NFRM) & CRx2

    t = Timer
    ReDim arr(1 To MAXR, 1 To 1)
    For i = 1 To MAXR
        arr(i, 1) = i
    Next
    Range("D1:D" & MAXR) = arr
    msg = msg & "2D Array:" & vbTab & Format(Timer - t, NFRM) & CRx2

    Debug.Print "Max itms: " & vbTab & Format(MAXR, "#,##0")
    Debug.Print msg
End Sub