使用VBA按每行2个先左后右再换行规则动态粘贴Excel单元格区域

核心思路 #

• 先获取你定义的命名区域Section 1的宽度（列数）和高度（行数），作为每次粘贴的偏移基准，避免区域重叠
• 通过循环索引的奇偶性判断当前粘贴位置是左侧还是右侧：奇数个贴在当前行最左侧，偶数个贴在同一行右侧
• 每贴完2个区域后，行偏移量叠加区域高度，实现自动换行

修正后的完整代码 #

Sub ArrangeSections()
    Dim ws As Worksheet
    Dim secRng As Range
    Dim secHeight As Long, secWidth As Long
    Dim i As Long, N As Long
    Dim pasteStartRow As Long, pasteStartCol As Long
    
    ' 初始化参数，根据实际情况修改
    Set ws = ThisWorkbook.Worksheets("你的工作表名") ' 替换为实际工作表名称
    Set secRng = ws.Range("Section 1") ' 调用你定义的命名区域
    secHeight = secRng.Rows.Count
    secWidth = secRng.Columns.Count
    N = 10 ' 示例值，替换为实际需要生成的区域数量
    pasteStartRow = 1 ' 第一个区域的起始行，可根据需要调整
    
    ' 复制原区域
    secRng.Copy
    
    For i = 1 To N
        ' 判断当前区域粘贴在左侧还是右侧
        If i Mod 2 = 1 Then
            ' 奇数位贴左侧，从A列开始
            pasteStartCol = 1
        Else
            ' 偶数位贴右侧，和左侧区域间隔1列
            pasteStartCol = secWidth + 2
        End If
        
        ' 粘贴到目标位置
        ws.Cells(pasteStartRow, pasteStartCol).PasteSpecial xlPasteAll
        
        ' 清空当前区域内的用户输入值，可根据实际清空范围调整参数
        ws.Cells(pasteStartRow, pasteStartCol).Offset(0, 1).Resize(3, 1).Value = 0
        
        ' 每贴完2个区域，起始行下移一个区域高度，实现换行
        If i Mod 2 = 0 Then
            pasteStartRow = pasteStartRow + secHeight
        End If
    Next i
    
    ' 清除剪贴板
    Application.CutCopyMode = False
End Sub

代码说明 #

• 原有代码每次固定从A列最后一行查找粘贴位置，只能实现竖向排列，替换为通过pasteStartRow和pasteStartCol两个变量动态计算粘贴起始位置，即可实现横向排列后自动换行的效果
• 清空值的部分使用Resize一次性赋值，不需要多次查找单元格位置，运行效率更高，如果你的清空范围不是3行，调整Resize的第一个参数即可
• 区域之间的间隔可自行调整，需要更大间隔的话，把pasteStartCol = secWidth + 2里的2改成更大的数值即可

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