在多个工作表的同一列中的查找值

Question

在关于我的工作簿中的五页三（面包，花卉，食品杂货店）列B，我想找到这个字行Flyer B列有将在每个工作表中多行这个字Flyer列B当找到单词Flyer ，它将把整行粘贴到Sheet1中。

我将其放在一个选项卡上，但是希望使用相同的代码搜索所有三个选项卡（但不是全部五个...这是问题所在），然后将B列中带有Flyer的单词的所有行粘贴到Sheet1中。

我的代码（有效，但仅在“面包店”选项卡上）：

Sub CopyRowsFlyer()
'This looks in the Bakery tab and moves everything that has "Flyer" in     column B to Sheet 1
  Dim bottomB As Integer
  Dim x As Integer
  bottomB = Sheets("Bakery").Range("B" & Rows.Count).End(xlUp).Row: x = 1

  Dim c As Range
  For Each c In Sheets("Bakery").Range("B3:B" & bottomB)
    If c.Value = "Flyer" Then
        c.EntireRow.Copy Worksheets("sheet1").Range("A" & x)
        x = x + 1
    End If
  Next c
End Sub

Answer 1

将所需的工作表名称存储在数组中并循环遍历它们。

Sub CopyRowsFlyer()
    Dim bottomB As Long, b As Long, x As Long
    Dim w As Long, vWSs As Variant
    vWSs = Array("Bakery", "Floral", "Grocery")

    x = 1
    For w = LBound(vWSs) To UBound(vWSs)
        With Worksheets(vWSs(w))
            bottomB = .Range("B" & Rows.Count).End(xlUp).Row
            For b = 3 To bottomB
                If LCase(.Cells(b, "B").Value) = "flyer" Then
                    .Rows(b).EntireRow.Copy Worksheets("sheet1").Range("A" & x)
                    x = x + 1
                End If
            Next b
        End With
    Next w

End Sub

尽管与.Range.Find方法之类的其他方法相比，这种在每个工作表的B列中的单元格循环的方法效率低下，但在较小的数据集上不会有太大的区别。 如果每个工作表上都有大量行要检查，则可能希望探索其他更直接的信息检索途径。

Answer 2

您只想遍历想要的三张纸。 尝试这个：

 Sub CopyRowsFlyer()
 'This looks in the Bakery tab and moves everything that has "Flyer" in     column B to Sheet 1
   Dim bottomB As Integer
   Dim x As Integer
   Dim SheetsArray() As Variant
   Dim ws As WorkSheet
   Dim i As Integer       

   SheetsArray = Array("Bakery", "Sheet2Name", "Sheet3Name")
   For i = LBound(SheetsArray) To UBound(SheetsArray)
        Set ws = Sheets(SheetsArray(i))
        bottomB = ws.Range("B" & Rows.Count).End(xlUp).Row: x = 1

        Dim c As Range
        For Each c In ws.Range("B3:B" & bottomB)
              If c.Value = "Flyer" Then
                    c.EntireRow.Copy Worksheets("sheet1").Range("A" & x)
                    x = x + 1
              End If
        Next c
   Next i
 End Sub

Answer 3

您可以将字符串数组的元素替换为表格中的ID。

这是修改后的代码以反映出来。

Sub CopyRowsFlyer()
  Dim bottomB As Integer
  Dim x As Integer
  Dim sheetName(1 to 3) As String, i as Integer
  sheetName(1) = "Bakery"
  sheetName(2) = "Floral"
  sheetName(3) = "Grocery"
  x=1
  For i = 1 to 3
    bottomB = Sheets(sheetName(i)).Range("B" & Rows.Count).End(xlUp).Row

    Dim c As Range
    For Each c In Sheets(sheetName(i)).Range("B3:B" & bottomB)
        If c.Value = "Flyer" Then
            c.EntireRow.Copy Worksheets("sheet1").Range("A" & x)
            x = x + 1
        End If
    Next c
  Next i
End Sub

Answer 4

与发布的其他解决方案类似。 很简单 替换范围检查的边界。 最小变量。 没有执行中间尺寸。

Sub CopyRowsFlyer()
  Dim strSh As Variant, c As Range, x As Integer
  x = 1

  For Each strSh In Array("Bakery", "Floral", "Grocery")
    For Each c In Worksheets(strSh).Range("B:B")
      If c = "" and c.Row > 2 Then
        Exit For
      ElseIf c = "Flyer" and c.Row > 2 Then
        c.EntireRow.Copy Worksheets("Sheet1").Range("A" & x)
        x = x + 1
      End If
    Next
  Next
End Sub