Excel VBA で特定のシートのみ除外

質問

ＶＢＡで以下のような、ブック内の全シートから特定の文字列が入った行のみを新しくシート作成して一覧化するマクロを組みました。
検索する時に保護解除するなど別の作業もあるため無駄に長くなっております。

Sub 検索()
Dim Sh As Worksheet, Rng As Range
Dim StrFind As String, Res As String
Dim Rw As Long, R As Long
Dim N As Integer
Const OutShName = "検索結果"
StrFind = InputBox("検索する文字列を入力してください。" & " 　　 検索する文字列は正確に。", "検索文字列")
If StrFind = vbNullString Then Exit Sub
Dim Ws As Worksheet
Application.ScreenUpdating = False
For Each Ws In Worksheets
Ws.Unprotect Password:=908118
Next
Application.ScreenUpdating = True
Application.ScreenUpdating = False
UserForm1.Show vbModeless
UserForm1.Repaint
For N = 1 To Worksheets.Count
If Worksheets(N).Name = OutShName Then
Set Sh = Worksheets(N)
Sh.Move after:=Worksheets(Worksheets.Count)
Sh.Cells.ClearContents
Exit For
End If
Next N
If N > Worksheets.Count Then
Set Sh = Sheets.Add(after:=Worksheets(Worksheets.Count))
Sh.Name = OutShName
End If
Worksheets(1).Rows(1).Copy Sh.Rows(1)
R = 2
For N = 1 To Worksheets.Count - 1
With Worksheets(N).UsedRange
For Rw = 1 To .Rows.Count
Set Rng = .Cells(Rw, 1).Resize(, .Columns.Count).Find(StrFind)
If Not Rng Is Nothing Then
Rng.EntireRow.Copy Sh.Rows(R)
R = R + 1
End If
Next Rw
End With
Next N
Unload UserForm1
ResultMsg:
If R < 3 Then
Res = "「" & StrFind & "」 は、見つかりません。"
For Each Ws In Worksheets
Ws.Protect Password:=908118
Next
Sheets("TOP").Select
Else
Columns("A:A").ColumnWidth = 20
Columns("C:C").ColumnWidth = 13
Rows("1:1").RowHeight = 30
Sheets("12月").Select
Rows("1:1").Select
Selection.Copy
Sheets("検索").Select
Range("A1").Select
Application.ScreenUpdating = True
Res = "「" & StrFind & "」 は、" & R - 2 & " 件 見つかりました。 " & _
String(2, vbLf) & Sh.Name & " に抽出しました。"

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Font.Bold = False
Selection.Font.Bold = True
End If
MsgBox Res, vbInformation, "検索完了"
Set Rng = Nothing
End Sub

Excel2003を使用してます。
シートは30枚程あり、複雑な計算式等が入っています。
この時、特定のシート（例:"月別データ")のみを除外したいのですが、いまいちわかっておりません。
稚拙な質問かと思いますがご指導していただきたく思います。

回答No.3

MarcoRossiItaly

う～ん、インデントしましょうね。長いし入れ子も多いし、何が何やら…なので。

if
　　if
　　　　for
　　　　　　処理
　　　　next
　　　　処理
　　end if
end if

みたいな具合に。また、ところどころ、行間にも改行を入れてしまったほうが見やすいかもしれません。

Application.ScreenUpdating を True にしたすぐ次の行で False にするとかは、意味がないので、そこは 2 行とも削除しましょう。

No.1 さんも No.2 さんも、多少の書きぶりの違いはあれ、「if worksheets(i).name <> "月別データ" then」という形で除外されていますね。お手元のデータの状況が分かればもっと効率の良い方法もあり得るかもしれませんが、この場の回答としてはこんな感じかと思います。

ベストアンサーは辞退します。

回答No.2

K Kazz（@JazzCorp）

'こんなカンジ？？
'後半はよくワカラン、、、
Sub 検索()
Const ExceptShName = "月別データ"
Const OutShName = "検索結果"
Dim Sh As Worksheet, Rng As Range
Dim StrFind As String, Res As String
Dim Rw As Long, R As Long
Dim N As Integer
StrFind = InputBox("検索する文字列を入力してください。" & " 　　 検索する文字列は正確に。", "検索文字列")
If StrFind = vbNullString Then Exit Sub
Dim Ws As Worksheet
Application.ScreenUpdating = False
For Each Ws In Worksheets
'Ws.Unprotect Password:=908118
Next
'UserForm1.Show vbModeless
'UserForm1.Repaint
For N = 1 To Worksheets.Count
If (Worksheets(N).Name = OutShName) Then
Set Sh = Worksheets(N)
Sh.Move after:=Worksheets(Worksheets.Count)
Sh.Cells.ClearContents
Exit For
End If
Next N
If (N > Worksheets.Count) Then
Set Sh = Sheets.Add(after:=Worksheets(Worksheets.Count))
Sh.Name = OutShName
End If
Application.CutCopyMode = True
Worksheets(1).Rows(1).Copy Sh.Rows(1)
R = 2
For N = 1 To Worksheets.Count - 1
'With Worksheets(N).UsedRange
With Worksheets(N)
Const xKey_Col = 1
Dim xLast As Long
Dim xLast_Col As Long
Dim nn As Long
If (Worksheets(N).Name <> ExceptShName) Then
xLast = .Cells(Rows.Count, xKey_Col).End(xlUp).Row
If (xLast > 1) Then
nn = 1
'For Rw = 1 To .Rows.Count
Do Until (nn >= xLast)
nn = nn + 1
xLast_Col = .Cells(nn, Columns.Count).End(xlToLeft).Column
Set Rng = .Cells(nn, xKey_Col).Resize(1, xLast_Col).Find(StrFind, LookAt:=xlWhole)
If Not (Rng Is Nothing) Then
Rng.EntireRow.Copy Sh.Rows(R)
R = R + 1
nn = Rng.Row
End If
Loop
End If
End If
End With
Next N

'Unload UserForm1
ResultMsg:
If R < 3 Then
Res = "「" & StrFind & "」 は、見つかりません。"
For Each Ws In Worksheets
'Ws.Protect Password:=908118
Next
Sheets("TOP").Select
Else
Columns("A:A").ColumnWidth = 20
Columns("C:C").ColumnWidth = 13
Rows("1:1").RowHeight = 30
Sheets("12月").Select
Rows("1:1").Select
Application.CutCopyMode = True
Selection.Copy
Sheets("検索").Select
Range("A1").Select
Res = "「" & StrFind & "」 は、" & R - 2 & " 件 見つかりました。 " & _
String(2, vbLf) & Sh.Name & " に抽出しました。"
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Font.Bold = False
Selection.Font.Bold = True
End If
MsgBox Res, vbInformation, "検索完了"
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

回答No.1

keithin

sub macro1()
　dim StrFind as string
　dim i as long
　dim c as range
　dim c0 as string
　dim N as long
　dim Res as string

　Const OutShName = "検索結果"

　'INPUT SEARCH WORD
　StrFind = InputBox("検索する文字列を入力してください。" & " 　　 検索する文字列は正確に。", "検索文字列")
　If StrFind = vbNullString Then Exit Sub

　'SETUP RESULT WORKSHEET
　on error goto errhandle
　with worksheets("検索結果")
　　.move after:=worksheets(worksheets.count)
　　.cells.clearcontents
　　worksheets("12月").rows(1).copy .range("A1")
　　.rows(1).value = .rows(1).value
　　.range("A:A").columnwidth = 20
　　.range("C:C").columnwidth = 13
　　.range("1:1").rowheight = 30
　　.range("1:1").font.bold = true
　end with
　on error goto 0

　'UNKNOWN USERFORM
　load userform1
　userform1.show vbmodeless
　userform1.repaint

　'ROTATE WORKSHEETS
　for i = 1 to worksheets.count - 1
　with worksheets(i)

　　'EXCLUSION
　　if .name <> "月別データ" and .name <> "AND SO ON" then

　　　'MAIN
　　　.unprotect password:=908118
　　　set c = .cells.find(what:=strfind, lookin:=xlvalues, lookat:=xlwhole)
　　　if not c is nothing then
　　　　c0 = c.address
　　　　do
　　　　　n = n + 1
　　　　　c.entirerow.copy destination:=worksheets("検索結果").rows(n + 1)
　　　　　set c = .cells.findnext(c)
　　　　loop until c.address = c0
　　　end if
　　　.protect password:=908118
　　end if
　end with
　next i

　'REPORT
　unload userform1
　if n = 0 then
　　Res = "「" & StrFind & "」 は、見つかりません。"
　else
　　Res = "「" & StrFind & "」 は、" & n & " 件 見つかりました。 " & _
　　String(2, vbLf) & " 検索結果に抽出しました。"
　end if
　MsgBox Res, vbInformation, "検索完了"
　exit sub

errhandle:
　'SETUP RES SHEET cont
　worksheets.add after:=worksheets(worksheets.count)
　activesheet.name = "検索結果"
　resume
end sub
みたいな。