VBA将可变干净数据区域粘贴到其他工作表时报1004错误咨询

核心报错原因 #

• 你通过Union拼接得到的clean_Range是不连续的多区域范围，Excel原生不支持将结构不规则的不连续区域直接粘贴到单个起始单元格，执行Copy/PasteSpecial操作时就会触发1004错误
• 缺少clean_Range非空校验：如果选中范围没有符合规则的干净数据，clean_Range为Nothing，调用任意属性/方法都会触发1004
• 逻辑规则冲突：干净数据的判断条件漏了等于上下限的情况，和异常数据的判定规则不匹配，会导致等于阈值的数据被错误归为脏数据，极端场景下会出现clean_Range为空的问题
• 冗余问题：两次遍历选中区域，逻辑不一致风险高，可合并为一次遍历

修复方案 #

如果需要把干净数据按原位置结构粘贴：可以先复制整列原数据，再把脏数据的内容清空，避免操作不连续区域；如果需要把干净数据按顺序连续粘贴到新表，可以直接遍历clean_Range的单元格逐个写入，规避不连续区域复制的限制。
修复后的完整代码如下：

Sub Data_cleanse()
'Perform Stats Analysis on Outlier Data.

'Specify Dims
Dim count_data_analyzed As Variant
Dim allRange As Range, aCell As Range, selectedRng As Range
Dim ws_instruction As Worksheet, ws_data As Worksheet, ws_output As Worksheet, ws_cleansed As Worksheet
Dim record_cell As Variant, Upper_limit As Variant, Lower_limit As Variant, count_outliers As Variant
Dim percent_outliers As Variant
Dim yesRange As Range, noRange As Range, dirty_range As Range, clean_Range As Range
Dim ExcludeNegatives As VbMsgBoxResult, ExcludeZeros As VbMsgBoxResult

'Highlight Outlier Data Points
Const yesColor As Long = 65280 '异常数据绿色
Const noColor As Long = 65535 '脏数据黄色
Const Clean_Color As Long = 15773696 '干净数据浅蓝色，避免和脏数据颜色重复

'Ascribe worksheets
Set ws_instruction = ThisWorkbook.Worksheets("Instruction Sheet")
Set ws_data = ThisWorkbook.Worksheets("Data Sheet")
Set ws_output = ThisWorkbook.Worksheets("Output Sheet")
Set ws_cleansed = ThisWorkbook.Worksheets("Cleansed Data")

ExcludeNegatives = MsgBox("Should all negative values be excluded from analysis?", vbQuestion + vbYesNo, "User Response")
ExcludeZeros = MsgBox("Should zero values be excluded from analysis?", vbQuestion + vbYesNo, "User Response")
Set selectedRng = Application.Selection

'Error handling to capture Cancel key.
On Error GoTo errHandler

'Define range.
Set selectedRng = Application.InputBox("Range", , selectedRng.Address, Type:=8)
record_cell = selectedRng.Address(ReferenceStyle:=xlA1, _
                           RowAbsolute:=False, ColumnAbsolute:=False)

'Format Output Information
ws_output.Cells(1, 1).Value = "Analysis Table"
ws_output.Cells(2, 1).Value = "Data Range Analyzed"
ws_output.Cells(6, 1).Value = "Upper Limit"
ws_output.Cells(7, 1).Value = "Lower Limit"
ws_output.Cells(8, 1).Value = "Number of Outliers"
ws_output.Cells(9, 1).Value = "Percent of Data"

Upper_limit = 15
Lower_limit = -20

If ExcludeNegatives = vbYes And Lower_limit < 0 Then
    Lower_limit = 0
Else
    Lower_limit = -20
End If

'处理排除零值的逻辑补全
If ExcludeZeros = vbYes Then
    '如果要排除零值，把下限设为略大于0即可，可根据业务调整精度
    If Lower_limit <= 0 Then Lower_limit = 0.0000001
End If

ws_output.Cells(2, 2).Value = record_cell
ws_output.Cells(6, 2).Value = Upper_limit
ws_output.Cells(7, 2).Value = Lower_limit

'合并为一次遍历构建所有区间
Set allRange = selectedRng
For Each aCell In allRange.Cells
   If IsNumeric(aCell) Then
      If aCell.Value > Upper_limit Or aCell.Value < Lower_limit Then
        '异常数据
         If yesRange Is Nothing Then
            Set yesRange = aCell
         Else
            Set yesRange = Union(aCell, yesRange)
         End If
      Else
        '干净数据
         If clean_Range Is Nothing Then
            Set clean_Range = aCell
         Else
            Set clean_Range = Union(aCell, clean_Range)
         End If
      End If
   Else
    '非数值数据归为脏数据
    If dirty_range Is Nothing Then
        Set dirty_range = aCell
    Else
        Set dirty_range = Union(aCell, dirty_range)
    End If
   End If
Next aCell

'非空校验，避免空对象报错
If Not yesRange Is Nothing Then yesRange.Interior.Color = yesColor
If Not clean_Range Is Nothing Then
    clean_Range.Interior.Color = Clean_Color
    '如果要连续粘贴到干净数据工作表，用逐单元格写入的方式
    Dim i As Long: i = 2
    For Each aCell In clean_Range.Cells
        ws_cleansed.Cells(i, 1).Value = aCell.Value
        i = i + 1
    Next aCell
    '如果要保留原位置结构粘贴，可以用下面的方法替代逐单元格写入
    'allRange.Copy ws_cleansed.Range("A2")
    'If Not yesRange Is Nothing Then yesRange.ClearContents
    'If Not dirty_range Is Nothing Then dirty_range.ClearContents
Else
    MsgBox "选中范围内无符合规则的干净数据", vbInformation
End If

Exit Sub
errHandler:
'Quit sub procedure when user clicks InputBox Cancel button.
If Err.Number = 424 Then
    Exit Sub
Else: MsgBox "Error: " & Err.Number & " " & Err.Description, vbOK
End If
End Sub

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