Select the same range in multiple workheets

Question

So I need to select the same range in all worksheets except "Sheet1". The range is dinamic based on the value "s1" on the column A. So I want to select what is in column B for the value s1, make it bold, then to count the s1 values in column C. This is what I have so far

Sub test()
    Dim ws As Worksheet
    Dim lastrow As Long
    Dim xRg As Range, yRg As Range, zRg As Range
    Dim cell As Range
    Dim C1 As Range



    For Each ws In ThisWorkbook.Worksheets
     If ws.Name <> "Sheet1" Then
        lastrow = Cells(Rows.Count, "A").End(xlUp).Row
        Application.ScreenUpdating = False
        
          For Each xRg In Range("A1:A" & lastrow)
            If xRg.Text = "s1" Then
                If yRg Is Nothing Then
                    Set yRg = Range("B" & xRg.Row).Resize(, 1)
                            k = 1
                            For Each cell In yRg
                                yRg.Cells(k, 2) = k
                                yRg.Cells.Select
                                k = k + 1
                             Next cell
                Else
                    Set yRg = Union(yRg, Range("B" & xRg.Row).Resize(, 1))

    If Not yRg Is Nothing Then yRg.Select
For Each C1 In yRg
  C1.EntireRow.Font.Bold = True
Next C1
End Sub

Answer 1

Try this code:

Option Explicit

Sub test()
    Dim ws As Worksheet
    Dim xRg As Range, yRg As Range

    Application.ScreenUpdating = False
    
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "Sheet1" Then
            ws.Cells.Font.Bold = False   ' clear bold formatting for debugging purposes
            Set yRg = Nothing
            For Each xRg In ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp))
                If xRg.Text = "s1" Then
                    If yRg Is Nothing Then
                        Set yRg = xRg.Offset(0, 1)
                    Else
                        Set yRg = Union(yRg, xRg.Offset(0, 1))
                    End If
                    xRg.Offset(0, 2) = yRg.Cells.Count 'set entry number
                End If
            Next xRg
            If Not yRg Is Nothing Then yRg.Font.Bold = True
        End If
    Next ws
    
    Application.ScreenUpdating = True
End Sub

Before

After