如何使用VBA复制单元格区域并沿对角线方向批量粘贴数据

需求说明 #

• 数据源为同一Excel工作表内固定区域A1:E1
• 粘贴规则：沿对角线方向偏移，行号、列号同步递增，目标区域依次为B2:F2、C3:G3、D4:H4……直至第3500行对应位置
• 原有代码仅支持单次粘贴到B2:F2，缺少循环逻辑无法完成批量操作，原有代码如下：

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

实现代码 #

全量粘贴（包含值、格式、公式等所有源区域内容） #

Sub DiagonalPaste()
    Dim ws As Worksheet
    Dim sourceRng As Range
    Dim i As Long
    
    ' 绑定工作表和源数据区域，按需修改工作表名
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set sourceRng = ws.Range("A1:E1")
    
    ' 关闭屏幕更新、自动计算提升运行速度
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    On Error GoTo ErrHandler ' 异常捕获，避免程序出错后Excel设置未还原
    
    ' 从第2行循环到第3500行，行号和列号同步偏移
    For i = 2 To 3500
        sourceRng.Copy Destination:=ws.Cells(i, i)
    Next i
    
    ' 操作完成后还原Excel设置
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "批量粘贴完成，共处理" & i - 2 & "条记录", vbInformation
    Exit Sub
    
ErrHandler:
    ' 出错时还原Excel设置
    Application.CutCopyMode = False
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "运行出错：" & Err.Description, vbCritical
End Sub

仅粘贴值（速度最快，适合不需要格式的场景） #

不需要操作剪贴板，直接通过数组赋值完成，3500次操作可瞬间完成，将上述代码循环部分替换为以下内容即可：

For i = 2 To 3500
    ws.Cells(i, i).Resize(1, sourceRng.Columns.Count).Value = sourceRng.Value
Next i

代码说明 #

• 对角线偏移核心规律：第n行对应的目标区域起始单元格为第n行、第n列，和源区域等宽（5列），直接对应Cells(n,n)作为粘贴起始位置即可
• 代码默认执行到第3500行，如需调整终止行，直接修改循环语句For i = 2 To 3500中To后的数字即可
• 运行前请确认工作表名称与代码中Worksheets("Sheet1")的名称一致，否则会报错

内容的提问来源于stack exchange，提问作者Macro