VBA负数值循环粘贴需求及现有代码技术咨询

需求说明 #

• 监测指定列数值，当存在负数时持续执行循环处理
• 将筛选出的负数数据粘贴至用户选择的目标工作簿
• 按顺序处理两类数据范围：先处理4oz相关区域，完成后在目标工作簿下移一个单元格，再处理8oz相关区域

现有代码 #

Sub Absolute_Value()
'
' Absolute_Value Macro
'Defining Terms

Dim sht As Worksheet
Dim sht1 As Worksheet
Dim sht2 As Worksheet
Dim sht3 As Worksheet
Dim nwbsht1 As Worksheet
Dim nwbsht2 As Worksheet
Dim nwbsht3 As Worksheet
Dim nwbsht4 As Worksheet
Dim nwbsht5 As Worksheet
Dim nwbsht6 As Worksheet
Dim nwbsht7 As Worksheet
Dim nwbsht8 As Worksheet
Dim rngToAbs As Range
Dim c As Range
Dim wb As Workbook
Dim nwb As Workbook
Dim Onhand As Range
Dim OnHand2 As Range
Dim OnHand1 As Range
Dim OnHand3 As Range
Dim Pallet As Range
Dim PalletType As Range
Dim Item As Range
Dim Item2 As Range
Dim UnitQty As Range
Dim CL As Range
Dim DL As Range
Dim OutputArray
Dim I As Long

'Setting ranges for PackPlan workbook
Set wb = Application.ActiveWorkbook

   With ActiveWorkbook.Worksheets("Arils Pack Plan ")
    Set rngToAbs = .Range("F7:F28")
    Set Item = .Range("B7:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
    Set PalletType = .Range("E7:E" & .Cells(.Rows.Count, "E").End(xlUp).Row)
End With

'Opening Recent ATS report

With Application.FileDialog(msoFileDialogOpen)
    .Filters.Clear
    .Filters.Add "Excel 2007-13", "*.xlsx; *.xlsm; *.xlsa"
    .AllowMultiSelect = False
    .Show
Application.Workbooks.Open .SelectedItems(1)
Set nwb = Application.ActiveWorkbook

End With

'Setting Ranges for Daily Need Worksheet

'4oz Range Setting

Set nwb = Application.ActiveWorkbook
Set nwbsht1 = nwb.Sheets("DAILY NEED (DR)")
Set Onhand = nwbsht1.Range("Q5:Q14")

Set nwb = Application.ActiveWorkbook
Set nwbsht2 = nwb.Sheets("DAILY NEED (DR)")
Set Pallet = nwbsht2.Range("E5:E14")

Set nwb = Application.ActiveWorkbook
Set nwbsht3 = nwb.Sheets("DAILY NEED (DR)")
Set OnHand1 = nwbsht3.Range("U5:U14")

Set nwb = Application.ActiveWorkbook
Set nwbsht4 = nwb.Sheets("DAILY NEED (DR)")
Set OnHand2 = nwbsht4.Range("Y5:Y14")


'8oz Range Setting
Set nwb = Application.ActiveWorkbook
Set nwbsht5 = nwb.Sheets("DAILY NEED (DR)")
Set OnHand3 = nwbsht5.Range("Q15:Q25")

Set nwb = Application.ActiveWorkbook
Set nwbsht6 = nwb.Sheets("DAILY NEED (DR)")
Set Pallet = nwbsht6.Range("E15:E25")

Set nwb = Application.ActiveWorkbook
Set nwbsht7 = nwb.Sheets("DAILY NEED (DR)")
Set OnHand1 = nwbsht7.Range("T15:T25")

Set nwb = Application.ActiveWorkbook
Set nwbsht8 = nwb.Sheets("DAILY NEED (DR)")
Set OnHand2 = nwbsht8.Range("Y15:Y25")

'Copy and Paste Loop for Units

nwb.Activate

 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

wb.Activate
wb.Sheets("Arils Pack Plan ").Range("F7").Resize(I, 1) = Application.Transpose(OutputArray)

nwb.Activate

ReDim OutputArray(1 To OnHand1.Cells.Count)
For Each DL In OnHand1.Cells
    If DL.Value < 0 Then
        OutputArray(I) = DL.Value
        I = I + 1
    End If
Next DL

wb.Activate
wb.Sheets("Arils Pack Plan ").Range("F7").Resize(I, 1) = Application.Transpose(OutputArray)
End Sub

优化后的代码实现 #

Sub LoopPasteNegativeValues()
    Dim sourceWB As Workbook
    Dim targetWB As Workbook
    Dim targetSht As Worksheet
    Dim drSht As Worksheet
    Dim pasteStartCell As Range
    Dim hasNegatives As Boolean
    Dim outputArr() As Variant
    Dim i As Long
    Dim cell As Range
    
    ' 设置源工作簿（当前打开的PackPlan工作簿）
    Set sourceWB = ThisWorkbook
    Set targetSht = sourceWB.Worksheets("Arils Pack Plan ")
    
    ' 让用户选择目标工作簿
    With Application.FileDialog(msoFileDialogOpen)
        .Filters.Clear
        .Filters.Add "Excel 文件", "*.xlsx; *.xlsm"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub ' 用户取消选择则退出
        Set targetWB = Workbooks.Open(.SelectedItems(1))
    End With
    Set drSht = targetWB.Worksheets("DAILY NEED (DR)")
    
    ' --------------------------
    ' 处理4oz数据范围
    ' --------------------------
    Do
        hasNegatives = False
        i = 1
        ReDim outputArr(1 To drSht.Range("Q5:Q14").Cells.Count, 1 To 1)
        
        ' 遍历4oz的Onhand列（Q5:Q14），收集负数
        For Each cell In drSht.Range("Q5:Q14")
            If cell.Value < 0 Then
                outputArr(i, 1) = cell.Value
                i = i + 1
                hasNegatives = True
            End If
        Next cell
        
        ' 如果有负数，粘贴到源工作簿
        If hasNegatives Then
            ' 确定粘贴起始位置（首次从F7开始，后续接在上次的下一行）
            If pasteStartCell Is Nothing Then
                Set pasteStartCell = targetSht.Range("F7")
            Else
                Set pasteStartCell = pasteStartCell.Offset(pasteStartCell.CurrentRegion.Rows.Count)
            End If
            pasteStartCell.Resize(i - 1, 1).Value = outputArr
        End If
        
    Loop While hasNegatives ' 直到该范围没有负数
    
    ' 完成4oz后，下移一个单元格作为8oz的粘贴起始点
    If Not pasteStartCell Is Nothing Then
        Set pasteStartCell = pasteStartCell.Offset(pasteStartCell.CurrentRegion.Rows.Count + 1)
    Else
        Set pasteStartCell = targetSht.Range("F7").Offset(1) ' 如果4oz没有数据，从F8开始
    End If
    
    ' --------------------------
    ' 处理8oz数据范围
    ' --------------------------
    Do
        hasNegatives = False
        i = 1
        ReDim outputArr(1 To drSht.Range("Q15:Q25").Cells.Count, 1 To 1)
        
        ' 遍历8oz的Onhand列（Q15:Q25），收集负数
        For Each cell In drSht.Range("Q15:Q25")
            If cell.Value < 0 Then
                outputArr(i, 1) = cell.Value
                i = i + 1
                hasNegatives = True
            End If
        Next cell
        
        ' 如果有负数，粘贴到源工作簿
        If hasNegatives Then
            pasteStartCell.Resize(i - 1, 1).Value = outputArr
            Set pasteStartCell = pasteStartCell.Offset(i - 1)
        End If
        
    Loop While hasNegatives ' 直到该范围没有负数
    
    MsgBox "数据粘贴完成", vbInformation
End Sub

关键修改说明 #

• 变量优化：删除冗余的工作表变量，统一使用sourceWB、targetWB、drSht等清晰命名的变量，提升代码可读性
• 循环逻辑实现：使用Do...Loop While结构，持续监测指定列的负数，直到没有负数时停止循环
• 粘贴位置控制：记录粘贴起始单元格pasteStartCell，4oz完成后自动下移一个单元格，再启动8oz的粘贴循环
• 数组处理优化：采用二维数组存储数据，避免使用Transpose可能出现的行数限制问题
• 用户交互优化：增加用户取消选择文件时的退出逻辑，避免报错

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