1つを除いたすべてのワークシートをループしてテキストを参照する行を選択します

Question

新しいワークシートの特定の行をコピーするためのコードはすでに見つかりましたが、「連結」を除くすべてのワークシートでループすることはできません。残りのワークシートには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' i.e. 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