多工作表间将查找数据复制到指定范围的VBA报错解决

我的VBA代码需求：读取第1行，查找特定条件，将符合条件的列设为搜索范围，在该列中查找特定名称（rs.Name），偏移至其右侧4列并复制对应数据，最终将复制的数据粘贴到同名工作表（rs.Name）的指定范围（PasteRange）中。目前复制功能正常，但粘贴时触发报错：

Object doesn't support this property or method

我怀疑是提前设置PasteRange导致的问题，但因涉及28个工作表，希望在循环前统一指定该范围以避免重复操作。参考.Copy Destination示例写法后，仍未解决问题，后续会清理代码中的冗余变量。

相关代码 #

工作表存在性检查函数

Function WorksheetExists(WSName As String) As Boolean
    On Error Resume Next
    WorksheetExists = Worksheets(WSName).Name = WSName
    On Error GoTo 0
End Function

主执行子过程

Sub FindData()

Dim shname As String
Dim rs As Worksheet
Dim SampleEnding As String
Dim rFind As Range, cFind As String
Dim ws As Worksheet
Dim wk As Workbook
Dim SampleLook As Range
Dim SampleFind As Range
Dim SampleFind2 As Range
Dim PasteRange As Range
Dim Name As String

Set wk = ThisWorkbook
Set PasteRange = Application.InputBox("What is the range you will be copying to? Ex. E2:H2", Type:=8)

Do Until WorksheetExists(shname)
shname = InputBox("Enter sheet name")

If StrPtr(shname) = 0 Then
MsgBox ("User Cancelled!")
Exit Sub

Else
If Not WorksheetExists(shname) Then MsgBox shname & " doesn't exist!", vbExclamation

End If

Loop

SampleEnding = Application.InputBox("What is the string of the data file you are using? Ex: *_1.D,* or *_2.D", Type:=2)

Set rFind = wk.Sheets(shname).Rows("1:1").Find(What:=SampleEnding, After:=wk.Sheets(shname).Range("XFD1"), LookIn:=xlValues, Lookat:=xlPart, _
    SearchOrder:=xlByRows, searchdirection:=xlNext, MatchCase:=False, SearchFormat:=False)

If rFind Is Nothing Then
    MsgBox "Value not found"
Else
    Debug.Print rFind.Column
    cFind = Split(wk.Sheets(shname).Cells(1, rFind.Column).Address(True, False), "$")(0)
    
End If

For Each rs In ThisWorkbook.Worksheets
   If rs.Name = "hexafluoroethane" Or rs.Name = "chlorotrifluoromethane" Or _
   rs.Name = "Trifluoromethane" Or rs.Name = "Octafluoropropane" Or rs.Name = "Difluoromethane" Or _
   rs.Name = "Pentafluoroethane" Or rs.Name = "Octafluorocyclobutane" Or rs.Name = "Fluoromethane" Or _
   rs.Name = "Tetrafluoroethylene" Or rs.Name = "Hexafluoropropene" Or rs.Name = "Trifluoroethane" _
   Or rs.Name = "hexafluoropropene oxide" Or rs.Name = "chlorodifluoromethane" Or rs.Name = "Tetrafluoroethane" Or rs.Name = "Decafluorobutane" _
   Or rs.Name = "Heptafluoropropane" Or rs.Name = "Octafluorocyclopentene" Or rs.Name = "Trichlorofluoromethane" Or rs.Name = "Dodecafluoro-n-pentane" _
   Or rs.Name = "Nonafluorobutane" Or rs.Name = "Tetradecafluorohexane" Or rs.Name = "Undecafluoropentane" Or rs.Name = "E1" _
   Or rs.Name = "Hexadecafluoroheptane" Or rs.Name = "Tridecafluorohexane" Or rs.Name = "Perfluorooctane" Or rs.Name = "Pentadecafluoroheptane" _
   Or rs.Name = "Heptadecafluorooctane" Or rs.Name = "E2" Then

Set SampleFind = Range(cFind & "6:" & cFind & "34").Find(rs.Name, LookIn:=xlValues)
    If Not SampleFind Is Nothing Then
        Set SampleFind2 = Range(SampleFind.Offset(0, 1), SampleFind.Offset(0, 4))
            If Not SampleFind2 Is Nothing Then
                wk.Sheets(shname).SampleFind2.Copy Destination:=wk.Sheets(rs.Name).PasteRange
            End If
    End If
    
End If

Next rs

End Sub

错误原因及修复方案 #

1. 核心错误：Range对象引用方式错误
   代码中wk.Sheets(shname).SampleFind2和wk.Sheets(rs.Name).PasteRange的写法不符合VBA语法规则：

   • SampleFind2是已经指向源工作表单元格的Range变量，无需再通过工作表对象调用；
   • PasteRange是用户选择的Range，但它默认属于当前活动表，需要明确映射到目标工作表rs的对应位置。

   替换报错的代码行：

   ' 原错误代码
   ' wk.Sheets(shname).SampleFind2.Copy Destination:=wk.Sheets(rs.Name).PasteRange
   ' 修复后代码
   SampleFind2.Copy Destination:=rs.Range(PasteRange.Address)
   

2. 额外修复：避免活动表依赖
   原代码中Range(cFind & "6:" & cFind & "34")未指定工作表，会默认使用活动表，可能导致错误，修改为：

   Set SampleFind = wk.Sheets(shname).Range(cFind & "6:" & cFind & "34").Find(rs.Name, LookIn:=xlValues)
   

3. 优化建议：简化工作表判断逻辑
   将需要遍历的工作表名称存入数组，用Match函数替代冗长的Or判断，提升代码可读性：

   Dim targetSheetNames As Variant
   targetSheetNames = Array( _
       "hexafluoroethane", "chlorotrifluoromethane", "Trifluoromethane", _
       "Octafluoropropane", "Difluoromethane", "Pentafluoroethane", _
       "Octafluorocyclobutane", "Fluoromethane", "Tetrafluoroethylene", _
       "Hexafluoropropene", "Trifluoroethane", "hexafluoropropene oxide", _
       "chlorodifluoromethane", "Tetrafluoroethane", "Decafluorobutane", _
       "Heptafluoropropane", "Octafluorocyclopentene", "Trichlorofluoromethane", _
       "Dodecafluoro-n-pentane", "Nonafluorobutane", "Tetradecafluorohexane", _
       "Undecafluoropentane", "E1", "Hexadecafluoroheptane", _
       "Tridecafluorohexane", "Perfluorooctane", "Pentadecafluoroheptane", _
       "Heptadecafluorooctane", "E2" _
   )
   
   For Each rs In ThisWorkbook.Worksheets
       If Not IsError(Application.Match(rs.Name, targetSheetNames, 0)) Then
           ' 执行查找复制逻辑
       End If
   Next rs
   

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