循环浏览除一个工作表外的所有行，并复制具有文本参考的select行

我已经find了下面的代码来复制一个新的工作表中的某一行，但我不能设法通过除“合并”之外的所有工作表循环。 剩下的工作表编号为1-40。

你们有想法吗？

Sub CommandButton1_Click() Dim strLastRow As String Dim rngC As Range Dim strToFind As String, FirstAddress As String Dim wSht As Worksheet Dim rngtest As String Application.ScreenUpdating = False Set wSht = Worksheets("1") strToFind = InputBox("Enter Search Criteria") With wSht.Range("A:A") Set rngC = .Find(what:=strToFind, LookAt:=xlPart) If Not rngC Is Nothing Then FirstAddress = rngC.Address Do strLastRow = Sheets("Consolidate").Range("A" & Rows.Count).End(xlUp).Row + 1 rngC.EntireRow.Copy Sheets("Consolidate").Cells(strLastRow, 1) Set rngC = .FindNext(rngC) Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress End If End With MsgBox ("Finished") End Sub 

Answer 1

 Option Explicit Sub CommandButton1_Click() Dim strLastRow As String Dim rngC As Range Dim strToFind As String, FirstAddress As String Dim ws As Worksheet Dim rngtest As String Application.ScreenUpdating = False strToFind = InputBox("Enter Search Criteria") For Each ws In ActiveWorkbook.Worksheets 'loops through all the sheets If ws.name <> "Consolidate" Then ' everyone except consolidate With ws.Range("A:A") ' searches by your criteria Set rngC = .Find(what:=strToFind, LookAt:=xlPart) If Not rngC Is Nothing Then FirstAddress = rngC.Address Do strLastRow = Sheets("Consolidate").Range("A" & Rows.Count).End(xlUp).Row + 1 rngC.EntireRow.Copy Sheets("Consolidate").Cells(strLastRow, 1) Set rngC = .FindNext(rngC) Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress End If End With End If Next ws ' next sheet MsgBox ("Finished") End Sub 

Answer 2

 Sub CommandButton1_Click() Dim strLastRow As String Dim rngC As Range Dim strToFind As String, FirstAddress As String Dim wSht As Worksheet Dim rngtest As String dim i as integer' used to iterate through all worksheets in your workbook Application.ScreenUpdating = False for i = 1 to Worksheets.count' ie will give you the number of worksheets in your workbook 'Set wSht = Worksheets("1") Set wSht = Worksheets(i)'take "control" of the worksheet i if lcase(wSht.name) <> "consolidation" then strToFind = InputBox("Enter Search Criteria") With wSht.Range("A:A") Set rngC = .Find(what:=strToFind, LookAt:=xlPart) If Not rngC Is Nothing Then FirstAddress = rngC.Address Do strLastRow = Sheets("Consolidate").Range("A" & Rows.Count).End(xlUp).Row + 1 rngC.EntireRow.Copy Sheets("Consolidate").Cells(strLastRow, 1) Set rngC = .FindNext(rngC) Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress End If End With end if next i MsgBox ("Finished") end sub