Как быстрее искать строку на всех листах в VBA?

Question

Я пытаюсь найти строку на всех листах, приведенный ниже код получает строку из каждой строки столбца на одном листе и находит ее на другом листе, а затем получает форматирование соответствующей ячейки за месяц.

Проблема здесь в том, что он очень медленный. Как мне сделать это быстрее? есть способ лучше?

Sub colorstatus()
Application.ScreenUpdating = False


Range("H1").Activate
Dim c As Range

'//loop it
For Each c In Range(Range("H2"), Range("H2").End(xlDown))
    est1 = Split(c, "_")(0) & "_" & Split(c, "_")(1)


ActiveWindow.ActivatePrevious

 Dim ws As Worksheet
 Dim ws1 As Worksheet
 Dim est As Range
 Dim strName As String
 Dim status As Range
 
 For Each ws1 In Worksheets
  Columns.EntireColumn.Hidden = False
  Rows.EntireRow.Hidden = False
Next
 
 On Error Resume Next
 strName = est1
 For Each ws In Worksheets
 With ws.UsedRange
 Set est = .Find(What:="*" & strName & "*", After:=.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole)
 If Not est Is Nothing Then
 ws.Activate
 GoTo 0
 End If
 End With
 Next ws
0

est.Activate
Set status = Cells.Find(What:="*May*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
    xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
    , SearchFormat:=False)
    

Range(Split(status.Address, "$")(1) & est.row).Copy


ActiveWindow.ActivatePrevious
c.Offset(0, 11).PasteSpecial Paste:=xlPasteFormats

Next
End Sub

Answer 1

Этот фрагмент кода завершит либо сообщение с адресом ячейки, в которой было найдено слово, либо сообщение о том, что слово не было найдено:

Option Explicit
Sub colorstatus()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Dim cell As Range
    Dim TheWord As String: TheWord = "dog_390"
    For Each ws In ThisWorkbook.Sheets
        Set cell = ws.Range("A:A").Find(TheWord, LookAt:=xlPart)
        If Not cell Is Nothing Then
            MsgBox "Word " & TheWord & "found in cell: " & cell.Address & " in worksheet: " & ws.Name
            End
        End If
    Next ws
    MsgBox "Word " & TheWord & " was not found on this workbook."
End Sub

Answer 2

Попробуйте следующий код, пожалуйста:

Sub colorstatus()
    Dim sh As Worksheet, celFound As Range, strWord As String
    Dim status As Range
    
     strWord = "dog_390"
    For Each sh In ActiveWorkbook.Sheets
        Set celFound = sh.Range("A:A").Find(strWord, LookAt:=xlPart)
        If Not celFound Is Nothing Then
            Set status = sh.Rows(1).Find(What:="May", After:=sh.Range("A1"), LookAt:=xlPart)
            If Not status Is Nothing Then
                Debug.Print sh.Name, sh.cells(celFound.Row, status.Column).Interior.Color, sh.cells(celFound.Row, status.Column).Address
                'do whatever you need with the found cell...
                '....
            Else
                Debug.Print sh.Name, "No month found"
            End If
        Else
            Debug.Print sh.Name, "No match found"
        End If
    Next sh
End Sub

Answer 3

Код ниже l oop все листы и генерировать окно сообщения со всеми именами листов имеют значение in. Вы можете изменить и попробовать:

Sub Macro1()

    Dim strSearch As String, strResults As String
    Dim rngFound As Range
    Dim ws As Worksheet
    
    strSearch = "Test"
    strResults = ""
    
    For Each ws In ThisWorkbook.Worksheets
        
        With ws
        
            Set rngFound = .Cells.Find(strSearch, LookIn:=xlValues, Lookat:=xlWhole)
            
            If Not rngFound Is Nothing Then
            
                If strResults = "" Then
                    strResults = "Searching value, " & strSearch & ", appears in " & ws.Name
                Else
                    strResults = strResults & ", " & ws.Name
                End If
                
            End If
            
        End With
        
    Next ws
    
    If strResults <> "" Then
        MsgBox strResults & "."
    End If
    
End Sub