[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『検索KEYに該当するデータがない場合の対処方法』（T2）
検索KEYに該当するデータがなかった場合に、そのKEYは飛ばして、
次のKEYに移行しつつ、なかったKEYの数を数えて、
コメントで表示する方法を教えてください。
よろしくお願い致します。
Sub 検索()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim name As String
'シート名の置換え
Set ws1 = Worksheets("KEY")
Set ws2 = Worksheets("DB")
Set ws3 = Worksheets("抜粋")
Sheets("KEY").Select
Range("B:B").Select
rw = 0
For Each rng In Selection
If rng.Value = "" Then
ret = rw
Exit For
End If
rw = rw + 1
Next
For i = 2 To rw '「KEY」の数だけループ
'シート「KEY」を選択
Sheets("KEY").Select
'「KEY」になるセルを選択
Rows(i & ":2").Select
'「KEY」になるセルの値を代入
name = (ws1.Cells(i, 2))
'選択したセルをコピー
Selection.Copy
'シート「DB」を選択
Sheets("DB").Select
'検索する対象列を選択
Columns("H:H").Select
※ここで該当データがないとエラーになってしまいます！
After:=ActiveCellのところでひっかかるようです。
この時、次のKEYに飛びつつ、エラーKEYの数を数えて、
一番最後にコメントで「10件該当なし」とかいう感じで
表示したいのです。
'KEYに該当するセルを検索
Selection.Find(What:=name, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False).Activate
'該当するセル
j = ActiveCell.Column '列
k = ActiveCell.Row '行
'該当するセルを含む行を選択する
Rows(k & ":" & k).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「抜粋」を選択
Sheets("抜粋").Select
'データをコピーしたい行を選択
Rows(i & ":" & i).Select
'選択した行にデータをペースト
ActiveSheet.Paste
Next
End Sub
After:=ActiveCellでエラーではなくて、.Activateだと思います。
検索の値が存在しないわけだから、そのセルをアクティブにはできませんよね。
そこをこう置き換えればいいかな。
'KEYに該当するセルを検索
Set adr = Selection.Find(What:=name, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Not adr Is Nothing Then '検索出来たとき
Range(adr.Address).Select
ElseIf vbYes = MsgBox("KEY " & name & " はありません", vbOKOnly) Then
End If
一番最後にコメントで「10件該当なし」～ というところは、自分で対応できますよね？
（ramrun）
『検索該当データが複数ある場合の対処方法』（T2）
昨日は「検索KEYに該当するデータがない場合の対処方法」に対するご回答、
ありがとうございました。早速ご教示に従い、作成してみましたら、
通るようになりました。
ここでまた質問なのですが、検索結果が複数ある場合、
全ての結果に対して同じ処理を行いたいのですが、どのようにしたらよいでしょう？
ご教示よろしくお願い致します。
Sub 検索()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Integer
Dim name As String
Dim name2 As String
Dim name3 As String
Dim name4 As String
Dim name5 As String
'シート名の置換え
Set ws1 = Worksheets("KEY")
Set ws2 = Worksheets("DB")
Set ws3 = Worksheets("抜粋")
Set ws4 = Worksheets("該当無")
'全検索数をカウント
Sheets("KEY").Select
Range("B:B").Select
rw = 0
For Each rng In Selection
If rng.Value = "" Then
ret = rw
Exit For
End If
rw = rw + 1
Next
l = 0
n = 0
For i = 2 To rw '「KEY」の数だけループ
'シート「KEY」を選択
Sheets("KEY").Select
'「KEY」になるセルを選択
Rows(i & ":2").Select
'「KEY」になるセルの値を代入
name = (ws1.Cells(i, 2))
'選択したセルをコピー
Selection.Copy
'シート「DB」を選択
Sheets("DB").Select
'検索する対象列を選択
Columns("H:H").Select
'KEYに該当するセルを検索
Set adr = Selection.Find(what:=name, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
'検索出来た時
※該当データが複数あった場合、ここから下の☆までの処理を全てに対して行いたいのですが・・・。
If Not adr Is Nothing Then
Range(adr.Address).Select
'該当するセル
j = ActiveCell.Column '列
k = ActiveCell.Row '行
'該当するセルの値
name2 = (ws2.Cells(k, 8))
'該当するセルを含む行を選択する
Rows(k & ":" & k).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「抜粋」を選択
Sheets("抜粋").Select
'データをコピーしたい行を選択
m = i - l
Rows(m & ":" & m).Select
'選択した行にデータをペースト
ActiveSheet.Paste
☆ここまでの処理を繰り返したい。
'検索出来なかった時
Else
'検索できなかった局数をカウント
l = l + 1
'検索できなかった局の局番を表示
name3 = "Key 「" & name & "」 はありません"
MsgBox name3
'シート「KEY」を選択
Sheets("KEY").Select
'該当するセルを含む行を選択する
Rows(i & ":" & i).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「該当無」を選択
Sheets("該当無").Select
Rows(l & ":" & l).Select
'選択した行にデータをペースト
ActiveSheet.Paste
End If
Next
'検索できなかった局数を表示
name4 = "検索できなかった局は「" & l & "」局です"
MsgBox name4
End Sub
どうしようか非常に迷ったんですが、なるべくT2さんのプログラムを生かす形で
修整してみました。
とくに説明しませんので確認してみてください。
あと処理上必要ない行はコメントアウトしました。
（ramrun）
Sub 検索()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Integer
Dim name As String
Dim name2 As String
Dim name3 As String
Dim name4 As String
Dim name5 As String
Dim firstaddress As String
'シート名の置換え
Set ws1 = Worksheets("KEY")
Set ws2 = Worksheets("DB")
Set ws3 = Worksheets("抜粋")
Set ws4 = Worksheets("該当無")
'全検索数をカウント
ws1.Select
Columns("B").Select
rw = 0
For Each rng In Selection
If rng.Value = "" Then
ret = rw
Exit For
End If
rw = rw + 1
Next
l = 0
n = 0
m = 2
For i = 2 To rw '「KEY」の数だけループ
'シート「KEY」を選択
ws1.Select
'「KEY」になるセルを選択
'Rows(i & ":2").Select
'「KEY」になるセルの値を代入
name = (ws1.Cells(i, 2))
'選択したセルをコピー
'Selection.Copy
'シート「DB」を選択
ws2.Select
'検索する対象列を選択
Columns("H").Select
'KEYに該当するセルを検索
Set adr = Selection.Find(what:=name, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Not adr Is Nothing Then firstaddress = adr.Address
'検索出来た時
Do While (1)
If Not adr Is Nothing Then
'Range(adr.Address).Select
'該当するセル
'j = adr.Column '列
k = adr.Row '行
'該当するセルの値
name2 = (ws2.Cells(k, 8))
'該当するセルを含む行を選択する
Rows(k).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「抜粋」を選択
ws3.Select
'データをコピーしたい行を選択
Rows(m).Select
'選択した行にデータをペースト
ActiveSheet.Paste
'検索出来なかった時
Else
'検索できなかった局数をカウント
l = l + 1
'検索できなかった局の局番を表示
name3 = "Key 「" & name & "」 はありません"
MsgBox name3
'シート「KEY」を選択
ws1.Select
'該当するセルを含む行を選択する
Rows(i).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「該当無」を選択
ws4.Select
Rows(l).Select
'選択した行にデータをペースト
ActiveSheet.Paste
Exit Do
End If
ws2.Select
Set adr = ws2.Columns("H").FindNext(adr)
m = m + 1
If firstaddress = adr.Address Then Exit Do
Loop
Next
'検索できなかった局数を表示
name4 = "検索できなかった局は「" & l & "」局です"
MsgBox name4
End Sub
『検索該当データが複数ある場合の対処方法の完成版』（T2）
昨日は『検索該当データが複数ある場合の対処方法』へのご返答、ありがとうございました。
早速ご教示頂いた内容を使用して、プラスまた機能を加えた形で作成してみました。
お陰様で、考えていた動作が可能となりました。
本当にありがとうございました。
一応、こんな形になったということで、完成版を記述しておきます。
Sub 検索()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Integer
Dim o As Integer
Dim p As Integer
Dim q As Integer
Dim name As String
Dim name2 As String
Dim name3 As String
Dim name4 As String
Dim name5 As String
Dim name6 As String
Dim name7 As String
Dim firstaddress As String
'シート名の置換え
Set ws1 = Worksheets("KEY")
Set ws2 = Worksheets("DB")
Set ws3 = Worksheets("抜粋")
Set ws4 = Worksheets("該当無")
Set ws5 = Worksheets("複数データ")
'全検索数をカウント
ws1.Select
Columns("B").Select
rw = 0
For Each rng In Selection
If rng.Value = "" Then
ret = rw
Exit For
End If
rw = rw + 1
Next
l = 0
n = 0
m = 2
o = 0
q = 0
For i = 2 To rw '「KEY」の数だけループ
'シート「KEY」を選択
'Sheets("KEY").Select
ws1.Select
'「KEY」になるセルを選択
Rows(i & ":2").Select
'「KEY」になるセルの値を代入
name = (ws1.Cells(i, 2))
'選択したセルをコピー
Selection.Copy
'シート「DB」を選択
ws2.Select
'検索する対象列を選択
Columns("H").Select
'KEYに該当するセルを検索
Set adr = Selection.Find(what:=name, After:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False)
If Not adr Is Nothing Then firstaddress = adr.Address
'検索出来た時
Do While (1)
'シート「DB」を選択
ws2.Select
If Not adr Is Nothing Then
Range(adr.Address).Select
'該当するセル
j = adr.Column '列
k = adr.Row '行
'該当するセルの値
name2 = (ws2.Cells(k, 8))
'該当するセルを含む行を選択する
Rows(k).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「抜粋」を選択
ws3.Select
'データをコピーしたい行を選択
Rows(m).Select
'選択した行にデータをペースト
ActiveSheet.Paste
'検索出来なかった時
Else
'検索できなかった局数をカウント
l = l + 1
'検索できなかった局の局番を表示
name3 = "Key 「" & name & "」 はありません"
MsgBox name3
'シート「KEY」を選択
ws1.Select
'該当するセルを含む行を選択する
Rows(i).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「該当無」を選択
ws4.Select
Rows(l).Select
'選択した行にデータをペースト
ActiveSheet.Paste
Exit Do
End If
ws2.Select
Set adr = ws2.Columns("H").FindNext(adr)
m = m + 1
'複数該当データがあるかチェック
'複数無ければ次のKEYへ
If firstaddress = adr.Address Then
Exit Do
'複数あればその局数をカウント
Else
p = 0
If p = 0 Then
q = q + 1
o = o + 1
'複数データがある局の局番を表示
name7 = "Key 「" & name & "」 は複数データがあります"
MsgBox name7
Range(firstaddress).Select
'該当するセル
j = ActiveCell.Column '列
k = ActiveCell.Row '行
'該当するセルの値
name6 = (ws2.Cells(k, 8))
'該当するセルを含む行を選択する
Rows(k).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「複数データ」を選択
ws5.Select
'データをコピーしたい行を選択
Rows(o).Select
'選択した行にデータをペースト
ActiveSheet.Paste
p = 1
End If
o = o + 1
ws2.Select
Range(adr.Address).Select
'該当するセル
j = adr.Column '列
k = adr.Row '行
'該当するセルの値
name5 = (ws2.Cells(k, 8))
'該当するセルを含む行を選択する
Rows(k).Select
'選択した行をコピー
Application.CutCopyMode = False
Selection.Copy
'シート「複数データ」を選択
ws5.Select
'データをコピーしたい行を選択
Rows(o).Select
'選択した行にデータをペースト
ActiveSheet.Paste
End If
Loop
p = 0
Next
'検索できなかった局数を表示
name4 = "複数データがあった局は「" & q & "」局、検索できなかった局は「" & l & "」局です"
MsgBox name4
End Sub
思いどおり動いてよかったですね。
（ramrun）
こちら事務局です。ご依頼のページを削除しました。
（ramrun）さんいつもありがとう。今後ともよろしく！
（kazu）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.