编写实现增量选区跨工作表复制的Excel VBA循环技术问询

以下是满足需求的完整VBA代码，可直接复制到Excel的VBA编辑器中使用：

Sub Copy38ColumnBlocks()
    Dim wsSource As Worksheet
    Dim wsTarget As Worksheet
    Dim startCol As Long
    Dim endCol As Long
    Dim lastRow As Long
    Dim targetStartRow As Long
    
    ' 替换为你的源工作表和目标工作表名称
    Set wsSource = ThisWorkbook.Worksheets("Sheet1")
    Set wsTarget = ThisWorkbook.Worksheets("Sheet2")
    
    startCol = 1 ' 首次复制起始列（A列）
    targetStartRow = 2 ' 首次粘贴起始行
    
    Do While startCol <= wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        endCol = startCol + 37 ' 每组38列，结束列为起始列+37
        
        ' 处理最后一组不足38列的情况
        If endCol > wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column Then
            endCol = wsSource.Cells(1, wsSource.Columns.Count).End(xlToLeft).Column
        End If
        
        ' 获取当前列块最后一列的非空行（从第2行开始统计）
        lastRow = wsSource.Cells(wsSource.Rows.Count, endCol).End(xlUp).Row
        
        ' 仅当有数据行时执行复制粘贴
        If lastRow >= 2 Then
            wsSource.Range(wsSource.Cells(2, startCol), wsSource.Cells(lastRow, endCol)).Copy
            wsTarget.Cells(targetStartRow, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
            
            ' 更新下一次粘贴的起始行
            targetStartRow = targetStartRow + (lastRow - 1)
        End If
        
        ' 切换到下一组38列
        startCol = endCol + 1
    Loop
    
    Application.CutCopyMode = False
    MsgBox "数据复制完成！"
End Sub

关键逻辑说明 #

• 工作表匹配：先修改代码中Sheet1和Sheet2为你实际使用的工作表名称。
• 列块循环：从A列（第1列）开始，每次向右偏移38列，直到覆盖源表所有有数据的列。
• 数据范围确定：以当前列块最后一列的非空行作为复制的结束行，确保只复制有效数据。
• 粘贴位置更新：每次粘贴后，自动计算目标表下一个空白行的位置，避免覆盖已有数据。
• 粘贴选项：默认使用xlPasteValuesAndNumberFormats保留数值和格式，若需要复制公式或格式，可替换为xlPasteAll。

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