How to copy a range and paste diagonally using vba - excel

Question

Hi If I have a range of data from A1:E1 and I want to copy and paste in the same sheet with incrementing both the column and row (in another word paste them diagonally), anyone can help with this vba?
my current code is this but this code only paste to B2:F2... i want to paste the data until row number 3500.. (with incrementing row and column).. data in A1:E1 is fix, so i would like to paste them to B2:F2, C3:G3, D4:H4 etc..
Sub m1()
Worksheets("Sheet1").Range("A1:E1").Copy
last_row = Worksheets("Sheet1").Range("B" & Worksheets("Sheet1").Rows.Count).End(xlUp).Row + 1
If last_row > 100000 Then last_row = 1
Worksheets("Sheet1").Range("B" & last_row).PasteSpecial
End Sub

Answer 1

There is no build-in function to copy diagonally. You will need to loop over all rows and copy the data individually.
The following piece of code shows you how that could look like
Const MaxRows = 3500
With Worksheets("Sheet1")
Dim r As Range
Set r = .Range("A1:E1")
r.Copy
Dim offset As Long
For offset = 1 To MaxRows
r.offset(offset, offset).PasteSpecial
Next
End With
However, this will be painfully slow. If you just want to copy data, you can change the code to
With Worksheets("Sheet1")
Dim r As Range, data
Set r = .Range("A1:E1")
data = r.Value2
Dim offset As Long
For offset = 1 To MaxRows
r.offset(offset, offset).Value2 = data
Next
End With

Answer 2

Copy Diagonally Using the Range.Copy Method
The Code
Option Explicit
Sub CopyDiagonallyTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
CopyDiagonally wb, "Sheet1", "A1:E1", 3499, 1, 1
' Note that you could omit the last two argument's parameters
' since they are optional and by default equal to 1.
End Sub
Sub CopyDiagonally( _
ByVal wb As Workbook, _
ByVal WorksheetName As String, _
ByVal SourceRangeAddress As String, _
Optional ByVal NumberOfCopies As Long = 1, _
Optional ByVal RowOffset As Long = 1, _
Optional ByVal ColumnOffset As Long = 1)
Const ProcName As String = "CopyDiagonally"
Dim dt As Double: dt = Timer ' measure duration
Dim n As Long
Dim LastAddress As String
Dim AnErrorOccurred
On Error GoTo ClearError
Dim ws As Worksheet: Set ws = wb.Worksheets(WorksheetName)
Dim srg As Range: Set srg = ws.Range(SourceRangeAddress)
Dim drg As Range: Set drg = srg
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
For n = 1 To NumberOfCopies
Set drg = drg.Offset(RowOffset, ColumnOffset)
LastAddress = drg.Address(0, 0) ' keep track in case of an error
srg.Copy drg
Next n
ProcExit:
On Error Resume Next
If Not Application.ScreenUpdating Then
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
dt = Timer - dt
Dim tString As String: tString = Format(dt, "0.###") & " seconds"
Dim MsgString As String
MsgString = "Diagonally Copying Stats" & vbLf & vbLf _
& "Source Range Address: '" & SourceRangeAddress & "'" & vbLf _
& "Number of Copies Created: " & n - 1 & " (" _
& NumberOfCopies & ")" & vbLf _
& "Last Range Address: '" & LastAddress & "'" & vbLf _
& "Operation Duration: " & tString
MsgBox MsgString, _
IIf(AnErrorOccurred, vbCritical, vbInformation), ProcName
Debug.Print MsgString
On Error GoTo 0
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
AnErrorOccurred = True
Resume ProcExit
End Sub
Results in the Immediate Window
Results for CopyDiagonally wb, "Sheet1", "A1:E1", 3499, 1, 1 (Requested)
Diagonally Copying Stats
Source Range Address: 'A1:E1'
Number of Copies Created: 3499 (3499)
Last Range Address: 'EDP3500:EDT3500'
Operation Duration: 34.305 seconds
Results for CopyDiagonally wb, "Sheet1", "A1:E1", 3499, 1, 500
(an error occurs since there are only 16384 columns)
'CopyDiagonally' Run-time error '1004':
Application-defined or object-defined error
Diagonally Copying Stats
Source Range Address: 'A1:E1'
Number of Copies Created: 163 (3499)
Last Range Address: 'XBY164:XCC164'
Operation Duration: 1.375 seconds