Excel VBA按Amounts表中Amount in USD开头列数重复粘贴区间求助

问题修复方案 #

原有代码核心问题 #

• 粘贴逻辑写在表头遍历循环内，会重复执行多次错误的粘贴操作，应该先统计完符合要求的列数再执行粘贴
• 未限定工作表的单元格引用，依赖活动工作表取值容易出现范围错误
• 不必要的Activate、Select操作，既降低运行效率也容易触发异常
• 缺少空值判断，当C列没有数据或者没有符合要求的表头时会报错

修复后可运行代码 #

Sub CopyAmountData()
    Dim wsSource As Worksheet, wsTarget As Worksheet
    Dim cel2 As Range
    Dim counter As Integer
    Dim copyRng As Range
    Dim lastRow As Long
    
    ' 定义工作表对象，避免后续频繁写工作表名
    Set wsSource = ThisWorkbook.Worksheets("Amounts")
    Set wsTarget = ThisWorkbook.Worksheets("Pasted Amounts")
    
    ' 第一步：统计符合要求的表头数量
    counter = 0
    With wsSource
        For Each cel2 In .Range("A2", .Range("A2").End(xlToRight))
            If cel2.Value Like "Amount in USD*" Then
                counter = counter + 1
            End If
        Next cel2
        ' 把计数写入U4单元格，和原有逻辑保持一致
        .Range("U4").Value = counter
    End With
    
    ' 无符合要求的表头直接退出，避免报错
    If counter = 0 Then
        MsgBox "未找到以「Amount in USD」开头的表头，无需粘贴"
        Exit Sub
    End If
    
    ' 第二步：定义要复制的C列数据范围
    With wsSource
        lastRow = .Range("C" & .Rows.Count).End(xlUp).Row
        ' C3以下没有数据直接退出
        If lastRow < 3 Then
            MsgBox "Amounts表C3以下无有效数据，无需粘贴"
            Exit Sub
        End If
        Set copyRng = .Range("C3:C" & lastRow)
    End With
    
    ' 第三步：一次性重复粘贴到目标位置
    wsTarget.Range("F2").Resize(copyRng.Rows.Count * counter).Value = copyRng.Value
End Sub

代码说明 #

• 先遍历表头统计counter数值，统计完成后再执行粘贴操作，逻辑更清晰
• 所有单元格引用都绑定了对应的工作表对象，不会受活动工作表切换影响
• 用直接赋值的方式替代复制粘贴，运行效率更高，也不会占用剪贴板
• 增加了两项异常判断，避免无符合要求表头或者无有效数据时的报错
• 如果需要保留原数据的格式，可以把最后一行的赋值代码替换为以下内容：

copyRng.Copy wsTarget.Range("F2").Resize(copyRng.Rows.Count * counter)

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