VBA粘贴循环故障：新增粘贴范围后无法继续执行

核心问题点 #

1. 变量I未重置：第一个循环结束后I保留了上次的计数，第二个循环直接沿用，导致数组索引越界，或填充的数组起始位置错位，粘贴时数据混乱。
2. 变量重复定义与覆盖：
   • 多个nwbsht*变量指向同一个工作表，属于冗余代码，完全没必要。
   • OnHand1、Pallet等变量被重复赋值，后续循环会使用覆盖后的范围，不符合原始需求。
3. 不必要的工作簿激活：频繁用Activate切换工作簿，容易触发运行时错误，且执行效率低下。
4. 数组粘贴范围计算错误：Resize(I,1)应该用I-1，因为每次找到符合条件的值后I会自增1，最终I的值比有效元素数多1。

修复后的代码 #

Dim wb As Workbook
Dim nwb As Workbook
Dim packPlanSht As Worksheet
Dim dailyNeedSht As Worksheet
Dim Onhand As Range
Dim OnHand2_4oz As Range
Dim OnHand1_4oz As Range
Dim OnHand3_8oz As Range
Dim Pallet_4oz As Range
Dim Pallet_8oz As Range
Dim OnHand1_8oz As Range
Dim OnHand2_8oz As Range
Dim OutputArray
Dim I As Long

' 设置PackPlan工作簿及工作表
Set wb = Application.ActiveWorkbook
Set packPlanSht = wb.Worksheets("Arils Pack Plan ")

' 打开ATS报告
With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    If .Show = -1 Then
        Set nwb = Application.Workbooks.Open(.SelectedItems(1))
        Set dailyNeedSht = nwb.Sheets("DAILY NEED (DR)")
    Else
        ' 用户取消选择文件，退出程序
        Exit Sub
    End If
End With

' 设置各范围（重命名变量避免覆盖）
' 4oz 范围
Set Onhand = dailyNeedSht.Range("Q5:Q14")
Set Pallet_4oz = dailyNeedSht.Range("E5:E14")
Set OnHand1_4oz = dailyNeedSht.Range("U5:U14")
Set OnHand2_4oz = dailyNeedSht.Range("Y5:Y14")

' 8oz 范围
Set OnHand3_8oz = dailyNeedSht.Range("Q15:Q25")
Set Pallet_8oz = dailyNeedSht.Range("E15:E25")
Set OnHand1_8oz = dailyNeedSht.Range("T15:T25")
Set OnHand2_8oz = dailyNeedSht.Range("Y15:Y25")

' 第一个循环：处理Onhand范围
I = 1
ReDim OutputArray(1 To Onhand.Cells.Count)
For Each CL In Onhand.Cells
    If CL.Value < 0 Then
        OutputArray(I) = CL.Value
        I = I + 1
    End If
Next CL
' 粘贴有效数据（用I-1，因为最后I多自增了一次）
packPlanSht.Range("F7").Resize(I - 1, 1) = Application.Transpose(OutputArray)

' 第二个循环：处理OnHand1_4oz范围
I = 1 ' 重置I为1，避免索引越界
ReDim OutputArray(1 To OnHand1_4oz.Cells.Count)
For Each DL In OnHand1_4oz.Cells
    If DL.Value < 0 Then
        OutputArray(I) = DL.Value
        I = I + 1
    End If
Next DL
' 若要粘贴到F7之后的位置，可调整起始单元格，比如Range("F7").Offset(已粘贴行数, 0)
packPlanSht.Range("F7").Offset(I - 1, 0).Resize(I - 1, 1) = Application.Transpose(OutputArray)

额外优化建议 #

如果需要处理更多范围，可把循环逻辑封装成子过程，避免重复代码：

Sub CopyNegativeValues(sourceRng As Range, targetStartCell As Range)
    Dim OutputArray
    Dim I As Long
    Dim cell As Range
    I = 1
    ReDim OutputArray(1 To sourceRng.Cells.Count)
    For Each cell In sourceRng.Cells
        If cell.Value < 0 Then
            OutputArray(I) = cell.Value
            I = I + 1
        End If
    Next cell
    If I > 1 Then
        targetStartCell.Resize(I - 1, 1) = Application.Transpose(OutputArray)
    End If
End Sub

调用时只需写：CopyNegativeValues Onhand, packPlanSht.Range("F7")，后续新增范围直接调用该子过程即可，不会再出现循环异常。

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