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

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

CodePudding user response：

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

CodePudding user response：

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

Copy Diagonally Using the Range.Copy Method

Copy Diagonally Using the `Range.Copy` Method