根据lastrow生成一个连续的数字
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 正如你所看到的，我试图将数据列从一个表单复制到另一个表单，并且效果很好。 但是如果注意到我正在生成一个从1到lastrow的p序列 ，这对我来说看起来很愚蠢，因为我正在使用一个循环，我相信还有另一种方法来生成它并将其复制到另一个表中。 我怎么能把这个作为删除应用程序。从代码中的转换（句点）行使它运行一半的时间。 如果有人能提供build议，我正在请求更快的方法。 谢谢。
例如
Sheet1 Sheet2 John 1 John Jim 2 Jim Jack 3 Jack
我从Sheet1生成Sheet2和数字和名称是在不同的列中。 我可以像我在我的代码中使用副本名称，但我需要自己生成的数字。
这将输出你正在寻找的两列; 一列中的数字和下一个中的名字：
Public Sub YourSolution() Dim v v = Sheet1.[CHOOSE({1,2},ROW(OFFSET(A1,,,COUNTA(A:A))),A1:INDEX(A:A,COUNTA(A:A)))] Sheet2.[b3:c3].Resize(UBound(v)) = v End Sub
它应该是足够快，你不必麻烦closures屏幕更新或设置计算手动。
我很好奇，所以我测量了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
。
testing代码：
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
所以你的问题是如何加快这一点？ 第一个build议是将以下内容添加到您的macros的开头和结尾处：
在开始时：
Application.ScreenUpdating = False Application.Calculation = xlCalculationManual
然后在最后：
Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True