在多个工作表中选择相同的范围答案

【问题标题】：Select the same range in multiple workheets在多个工作表中选择相同的范围
【发布时间】：2021-08-07 12:58:09
【问题描述】：

所以我需要在所有工作表中选择相同的范围，除了“Sheet1”。该范围是基于 A 列上的值“s1”的动态范围。所以我想为值 s1 选择列 B 中的内容，使其变为粗体，然后计算列 C 中的 s1 值。这就是我目前所拥有的

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

【问题讨论】：

lastrow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row，然后是For Each xRg In ws.Range("A1:A" & lastrow)。您必须完全限定所有涉及的范围...否则，您的代码仅适用于活动工作表。

标签： vba range counter

【解决方案1】：

试试这个代码：

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

之前

之后

【讨论】：

【解决方案2】：

选择或范围不会跨越多个工作表；每张纸都有一个选择。所以你需要在每张纸上工作。

你有很多未闭合的循环和条件。这是我对您尝试做的最好的猜测：

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

    For Each ws In ThisWorkbook.Worksheets
      If ws.Name <> "Sheet1" Then
        Set yRg = Nothing
        lastrow = Cells(Rows.Count, "A").End(xlUp).Row
        For Each xRg In Range("A1:A" & lastrow)
            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
            End If
        Next xRg
        If Not yRg Is Nothing Then
            s1count = 0
            For Each cell In yRg
                cell.EntireRow.Font.Bold = True
                s1count = s1count + 1
                cell.Offset(0, 1) = s1count
            Next cell
        End If
      End If
    Next ws

End Sub

【讨论】：