Generate a straight sequence of numbers depending on the lastrow - 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
As you see, I am trying to copy data columns from one sheet to another and it works well. But if notice I am generating a sequence in p from 1 to lastrow , which looks very dumb to me because I am using a loop and I am sure there is another way to generate it and copy it in to another sheet. How can I fasten this as removing the application.transpose(period) line from the code makes it run in half the time. I am requesting for an faster method if anyone can advice on. Thanks.
E.g.
Sheet1 Sheet2
John 1 John
Jim 2 Jim
Jack 3 Jack
I am generating Sheet2 from Sheet1 and the numbers and names are in different columns. I can use copy like I have in my code for names, but I need to generate the numbers myself.

Answer 1

I was curious about this so I measured 4 options:
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
.
Test code:
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

Answer 2

This will output both the columns you are looking for; numbers in one column and the names in the next:
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
It should be quick enough that you need not bother turning off screen updating or setting calculation to manual.

Answer 3

So your question is how to speed this up? A first suggestion is to add the following to the beginning and end to your Macro:
At the beginning:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
then at the end:
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True