在工作表中搜索单元格值，然后将相邻单元格复制到变量范围中答案

【问题标题】：Search a worksheet for a cell value, then copy the adjacent cells into a variable range在工作表中搜索单元格值，然后将相邻单元格复制到变量范围中
【发布时间】：2020-05-15 11:55:56
【问题描述】：

我有几个 Excel 工作簿，每个工作簿包含多个工作表。

我使用特定值（“James Smith”）在所有工作表中进行关键字搜索。如果找到该值，那么我需要从该单元格位置偏移五列（即“找到的单元格”将始终位于 C 列某处，因此偏移量指向 H 列），然后选择/复制相邻行进入最终将粘贴到新工作表“masterSheet”中的范围。

问题是：

每个工作表中的单元格地址会有所不同，因此每个工作表中的单元格地址都不相同
当我尝试设置下面的 FoundRange 值时出现错误。

    'Search multiple workbooks, look only for sheetnames that begin with "Week of" and don't contain the word "old"
    
    If currentSheet.Name Like "*Week of*" And InStr(currentSheet.Name, "Old") = 0 Then
        'If currentSheet.Name Like "*Week of*" Then
                
        'Within the current sheet look for a cell that contains "James Smith"
        With currentSheet
                
            .Range("C:C").Columns.Select
                
            Set FoundCell = Selection.Find(What:="James Smith", After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
              MatchCase:=False, SearchFormat:=False)
                
            'When "James Smith" is found in the current worksheet, get the cell address and offset from that cell location"
            OffsetCell = currentSheet.Range(FoundCell.Address).Offset(0, 5).Address
    
            'In Column "H" select the adjacent non-blank cells and copy into a range <line below where I define "FoundRange" is where I keep getting the "runtime error 424 object required error"
            Set FoundRange = Range(OffsetCell, OffsetCell.End(xlDown))

            For Each cell In currentSheet.Range(FoundRange)
                If Not IsEmpty(cell) Then
                    currentSheet.Range(cell.Address).Copy
                    masterSheet.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Format(CDate(Replace(Replace(currentSheet.Name, "Week of ", " "), ".", "/")), "mm/dd/yyyy")
                    masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(0, -1) = "James Bradford"
                    currentSheet.Range(cell.Address).Offset(0, 1).Copy
                    masterSheet.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    currentSheet.Range(cell.Address).Offset(0, 2).Copy
                    masterSheet.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    currentSheet.Range(cell.Address).Offset(0, 3).Copy
                    masterSheet.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                End If
            Next              
        End With
    End If

【问题讨论】：

OffsetCell 是一个字符串，所以OffsetCell.End(xlDown) 没有意义，它必须是一个范围set OffsetCell=FoundCell.Offset(0, 5)。另请阅读stackoverflow.com/questions/10714251/…
你可以做Set FoundCell = .Range("C:C").Find(...。
而currentSheet.Range(FoundRange) 应该只是FoundRange，因为它已经是一个范围。也许做一些关于范围的阅读。

标签： excel vba

【解决方案1】：

这行得通。仅供参考...你有詹姆斯史密斯在寻找和詹姆斯布拉德福德在循环中。我添加了一个 mastersheet 用于测试，所以去掉“Set masterSheet”这一行。

Sub RngTest()
'Search multiple workbooks, look only for sheetnames that begin with "Week of" and don't contain the word "old"

Set currentSheet = ActiveSheet
Set masterSheet = ActiveWorkbook.Sheets("MasterSheet")
If currentSheet.Name Like "*Week of*" And InStr(currentSheet.Name, "Old") = 0 Then
    'If currentSheet.Name Like "*Week of*" Then

        'Within the current sheet look for a cell that contains "James Smith"
        With currentSheet

        .Range("C:C").Columns.Select

        Set FoundCell = Selection.Find(What:="James Smith", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        'When "James Smith" is found in the current worksheet, get the cell address and offset from that cell location"
        Set OffsetCell = currentSheet.Range(FoundCell.Address).Offset(0, 5)

         'In Column "H" select the adjacent non-blank cells and copy into a range <line below where I define "FoundRange" is where I keep getting the "runtime error 424 object required error"
         Set FoundRange = Range(OffsetCell, OffsetCell.End(xlDown))

                 For Each cell In FoundRange.Cells
                    If Not IsEmpty(cell) Then
                        currentSheet.Range(cell.Address).Copy
                        masterSheet.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(1, 0) = Format(CDate(Replace(Replace(currentSheet.Name, "Week of ", " "), ".", "/")), "mm/dd/yyyy")
                        masterSheet.Range("C" & Rows.Count).End(xlUp).Offset(0, -1) = "James Bradford"
                        currentSheet.Range(cell.Address).Offset(0, 1).Copy
                        masterSheet.Range("E" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        currentSheet.Range(cell.Address).Offset(0, 2).Copy
                        masterSheet.Range("F" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                        currentSheet.Range(cell.Address).Offset(0, 3).Copy
                        masterSheet.Range("G" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
                    End If
                Next


        End With

    End If

结束子

【讨论】：