こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

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

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

投稿日時 - 2013-03-16 02:15:34

QNo.7995561

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(3)

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

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

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

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

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

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

投稿日時 - 2013-03-17 14:11:12

ANo.2

'こんなカンジ??
'後半はよくワカラン、、、
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

投稿日時 - 2013-03-16 15:32:24

ANo.1

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
みたいな。

投稿日時 - 2013-03-16 03:54:11

あなたにオススメの質問