Excel VBA循环复制每4列5行数据至USD工作表问题求助

嘿，作为VBA新手碰到循环逻辑的问题太正常了！我先帮你拆解下原代码的核心问题，再给你一套能正常运行的方案～

原代码的核心问题 #

• 固定选择Range("A5:D9")，没有实现「每次增加4列」的循环逻辑
• 每次运行都会新建名为USD的工作表，重复运行会触发“工作表已存在”的报错
• 缺少循环终止条件（不知道什么时候要停在最后一列）
• 过度使用Select/Activate，这是VBA新手常见的坑，容易导致代码不稳定

修正后的完整代码 #

Sub CopyColumnsToUSD()
    Dim wsSource As Worksheet
    Dim wsUSD As Worksheet
    Dim lastCol As Long
    Dim currentCol As Long
    Dim pasteRow As Long
    
    ' 定义源工作表（你的Test表）
    Set wsSource = ThisWorkbook.Worksheets("Test")
    ' 检查USD表是否存在，不存在则新建
    On Error Resume Next
    Set wsUSD = ThisWorkbook.Worksheets("USD")
    On Error GoTo 0
    If wsUSD Is Nothing Then
        Set wsUSD = ThisWorkbook.Worksheets.Add(After:=wsSource)
        wsUSD.Name = "USD"
    End If
    
    ' 获取源表最后一列的列号（以第5行有数据的列为准）
    lastCol = wsSource.Cells(5, wsSource.Columns.Count).End(xlToLeft).Column
    ' 初始化起始列和粘贴行
    currentCol = 1
    pasteRow = 1
    
    ' 循环：每次处理4列，步长为4
    Do While currentCol <= lastCol
        ' 复制源表中从currentCol开始的4列、5行数据（行5到行9）
        wsSource.Range(wsSource.Cells(5, currentCol), wsSource.Cells(9, currentCol + 3)).Copy
        ' 粘贴到USD表的当前粘贴行，只粘贴值
        wsUSD.Cells(pasteRow, 1).PasteSpecial Paste:=xlPasteValues
        ' 更新下一次循环的列和粘贴行
        currentCol = currentCol + 4
        pasteRow = pasteRow + 5 ' 因为每次复制5行，所以粘贴行往下跳5行
        Application.CutCopyMode = False ' 清除复制状态
    Loop
    
    MsgBox "数据复制完成！", vbInformation
End Sub

关键逻辑说明 #

• 避免重复新建工作表：先检查USD表是否存在，不存在才新建，解决重复运行报错的问题
• 动态获取最后一列：用Cells(5, Columns.Count).End(xlToLeft).Column找到第5行有数据的最后一列，确保循环能覆盖所有有数据的列
• 循环步长设置：currentCol = currentCol + 4实现每次跳过4列，正好对应你要的「每4列一组」的需求
• 取消Select/Activate：直接引用工作表对象操作，代码更稳定、效率更高
• 粘贴行自动更新：每次粘贴后把粘贴行往下移5行，确保每组数据不会重叠

对应你原代码的需求点 #

• 你标注的**「我希望每次增加4列，直到包含数据的最后一列」**：通过Do While currentCol <= lastCol循环+currentCol = currentCol +4实现
• 你提到的**「第二次循环应如下」**：第二次循环会自动处理E5:H9（假设第一次是A5:D9），并粘贴到USD表的第6行开始的位置

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