Question

我试过改变到处都有一个细胞到一个范围和其他东西，但我无法弄明白。我希望代码能够搜索整个工作表而不是一个单元格来查找这些名称，并将单元格的信息粘贴到另一个工作表的右边。

Option Explicit

Private Sub CommandButton1_Click()

Dim ws As Worksheet, myCounter As Long
Dim erow As Long, myValue As Long
Dim nextValue As Long

For Each ws In ThisWorkbook.Sheets
With ws
    Select Case .Range("C3").Value
        Case "David", "Andrea", "Caroline"
            myCounter = 1 ' raise flag >> found in at least 1 sheet

            ' get first empty row in "Report" sheet
            erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).Row
            Worksheets("Report").Cells(erow, 1) = .Range("C3").Value

    End Select ' Select Case .Range("C3").Value
End With
Next ws

If myCounter = 0 Then
MsgBox "None of the sheets contains the names " & Chr(10) & " 'David', 'Andrea', 'Caroline' in cell C3 ", vbInformation, "Not Found"
End If

End Sub

Answer 1

您可以将Application.Match与阵列版本一起使用。将其替换为循环：

Dim ar, r
For Each ws In ThisWorkbook.Sheets
    ar = Application.match(Array("David", "Andrea", "Caroline"), ws.Columns("C"), 0)
    For Each r In ar
        If Not IsError(r) Then
            myCounter = 1 ' raise flag >> found in at least 1 sheet
            erow = Worksheets("Report").Cells(Worksheets("Report").Rows.Count, 1).End(xlUp).Offset(1, 0).row
            Worksheets("Report").Cells(erow, 1) = ws.Range("C" & r).value
            Worksheets("Report").Cells(erow, 2) = ws.Range("D" & r).value
        End If
    Next r
Next ws

请注意，这将为每个单词找到一个匹配项，即第一个单词。如果每个单词可以重复多次并且您想要找到所有匹配项，则需要进行一些修改。

Answer 2

“查找”命令可以更好地为多行和多列提供服务。

Option Explicit

Private Sub CommandButton1_Click()

    Dim ws As Worksheet, bFound As Boolean, rFound As Range
    Dim a As Long, aNames As Variant

    aNames = Array("David", "Andrea", "Caroline")

    For Each ws In ThisWorkbook.Worksheets
        'If ws.Name <> Worksheets("Report").Name Then
        If ws.Name = "Sheet7" Then
            With ws.Range("A1:E30").Cells
                For a = LBound(aNames) To UBound(aNames)
                    Set rFound = .Find(What:=aNames(a), MatchCase:=False, LookAt:=xlWhole, SearchFormat:=False)
                    If Not rFound Is Nothing Then
                        bFound = True
                        With Worksheets("Report")
                            .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0) = rFound.Value
                        End With
                    End If
                Next a
            End With
        End If
    Next ws

    If Not bFound Then
        MsgBox "None of the sheets contains the names " & Chr(10) & _
            "'" & Join(aNames, "', '") & "' in cells A1:E30.", vbInformation, "Not Found"
    End If

End Sub

将搜索从一个单元格更改为整个工作表

2 个答案: