Excel VBA复制负数对应数据失败：粘贴无内容问题排查

需求：从新打开的工作簿中，复制cases为负数对应的pallet type、SKU及对应cases值，粘贴到当前工作簿。现有代码看似执行了复制操作，但无法完成粘贴。

原代码 #

Sub buildPlan()
'
' buildPlan Macro
'
    Dim wb As Workbook
    Dim colValsF, colValsE, colValsB As Collection
    Dim v, arr, c, d, e As Range
    Dim nwb As Workbook, wsAPP As Worksheet, wsDNDR As Worksheet
    
    Set wb = Application.ActiveWorkbook           'ThisWorkbook?
    Set wsAPP = wb.Worksheets("Arils Pack Plan ") 'trailing space?
    
    '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
    
    Set wsDNDR = nwb.Worksheets("DAILY NEED (DR)")
    
    Set colValsE = New Collection
    Set colValsF = New Collection
    Set colValsB = New Collection
    'Collect Pallet----------------------------------------------------------------------------------------------------------------------------------------------
    
    Set d = wsDNDR.Range("E5:E14,E15:E25").Cells
    
    For Each c In wsDNDR.Range("Q5:Q14,T5:T14,Q15:Q25,T15:T25").Cells
        v = c.Value
        If v < 0 Then colValsE.Add d
    Next c
    
    arr = CollectionToArray(colValsE) 'transfer the collection values to an array
    If Not IsEmpty(arr) Then
        wsAPP.Range("E7").Resize(UBound(arr, 1), 1) = arr 'place the array on the sheet
    End If
  'Collect SKU --------------------------------------------------------------------------------------------------------------------------------------------------
  
  Set e = wsDNDR.Range("B5:B14,B15:B25").Cells
  
  For Each c In wsDNDR.Range("Q5:Q14,T5:T14,Q15:Q25,T15:T25").Cells
        v = c.Value
        If v < 0 Then colValsB.Add e
    Next c
    
    arr = CollectionToArray(colValsB) 'transfer the collection values to an array
    If Not IsEmpty(arr) Then
        wsAPP.Range("B7").Resize(UBound(arr, 1), 1) = arr 'place the array on the sheet
    End If
    
    
    'collect all of the negative values----------------------------------------------------------------------------------------------------------------------------
    For Each c In wsDNDR.Range("Q5:Q14,T5:T14,Q15:Q25,T15:T25").Cells
        v = c.Value
        If v < 0 Then colValsF.Add v
    Next c
    
    arr = CollectionToArray(colValsF) 'transfer the collection values to an array
    If Not IsEmpty(arr) Then
        wsAPP.Range("F7").Resize(UBound(arr, 1), 1) = arr 'place the array on the sheet
    End If
    
End Sub

问题分析与修正方案 #

核心问题点 #

• 变量声明不规范：VBA中Dim colValsF, colValsE, colValsB As Collection仅最后一个变量为Collection类型，前两个默认是Variant；同理v, arr, c, d, e As Range仅最后一个是Range类型，其余为Variant，易导致类型错误。
• 错误收集Range对象而非单元格值：收集Pallet和SKU时，原代码直接将整个Range对象d/e加入集合，而非对应行的单元格值，导致后续数组赋值失败。
• 依赖未定义的CollectionToArray函数：若未提前实现该函数，代码会直接报错中断。
• 工作表名称存在潜在问题："Arils Pack Plan "末尾有空格，需确认当前工作簿中目标工作表名称完全一致，否则会找不到工作表。

修正后的代码 #

Sub buildPlan()
'
' buildPlan Macro
'
    Dim wb As Workbook
    Dim colValsF As Collection, colValsE As Collection, colValsB As Collection
    Dim v As Variant, arr As Variant, c As Range, d As Range, e As Range
    Dim nwb As Workbook, wsAPP As Worksheet, wsDNDR As Worksheet
    
    ' 明确使用当前运行代码的工作簿，避免ActiveWorkbook切换问题
    Set wb = ThisWorkbook
    ' 确认工作表名称无多余空格，若实际名称有空格则保留
    Set wsAPP = wb.Worksheets("Arils Pack Plan")
    
    ' 打开目标工作簿
    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))
        Else
            ' 用户取消选择文件，直接退出
            Exit Sub
        End If
    End With
    
    Set wsDNDR = nwb.Worksheets("DAILY NEED (DR)")
    
    Set colValsE = New Collection
    Set colValsF = New Collection
    Set colValsB = New Collection
    
    ' 遍历所有需要检查的cases单元格
    For Each c In wsDNDR.Range("Q5:Q14,T5:T14,Q15:Q25,T15:T25").Cells
        v = c.Value
        If IsNumeric(v) And v < 0 Then
            ' 收集对应行的Pallet Type（E列）
            colValsE.Add wsDNDR.Cells(c.Row, "E").Value
            ' 收集对应行的SKU（B列）
            colValsB.Add wsDNDR.Cells(c.Row, "B").Value
            ' 收集负数cases值
            colValsF.Add v
        End If
    Next c
    
    ' 将集合转数组并写入当前工作簿
    If colValsE.Count > 0 Then
        arr = CollectionToArray(colValsE)
        wsAPP.Range("E7").Resize(UBound(arr, 1), 1) = arr
    End If
    
    If colValsB.Count > 0 Then
        arr = CollectionToArray(colValsB)
        wsAPP.Range("B7").Resize(UBound(arr, 1), 1) = arr
    End If
    
    If colValsF.Count > 0 Then
        arr = CollectionToArray(colValsF)
        wsAPP.Range("F7").Resize(UBound(arr, 1), 1) = arr
    End If
    
    ' 可选择关闭新工作簿，根据需求调整
    ' nwb.Close SaveChanges:=False
End Sub

' 实现Collection转数组的函数
Function CollectionToArray(col As Collection) As Variant
    Dim arr() As Variant
    ReDim arr(1 To col.Count, 1 To 1)
    
    Dim i As Integer
    For i = 1 To col.Count
        arr(i, 1) = col(i)
    Next i
    
    CollectionToArray = arr
End Function

关键修正说明 #

• 变量声明：逐个明确变量类型，避免Variant类型导致的潜在错误。
• 数据收集逻辑：通过c.Row获取当前负数cases所在行，直接提取对应B列（SKU）和E列（Pallet Type）的单元格值加入集合，确保收集的是有效数据而非Range对象。
• 添加CollectionToArray函数：直接在代码中实现集合转数组的逻辑，避免依赖外部未定义函数。
• 增加文件选择判断：用户取消选择文件时直接退出，避免后续代码报错。
• 明确工作簿对象：使用ThisWorkbook指代当前运行代码的工作簿，避免打开新文件后ActiveWorkbook切换导致的错误。

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