Results of 0 - 1 of about 0 (0.000 sec.)
- [[20020514143945]]
- @digest: fb96071b95692ff801eea31c59565a9f
- @id: 37
- @mdate: 2003-04-29T06:41:49Z
- @size: 16595
- @type: text/plain
- #keywords: 粋") (42032), た局 (41734), 局数 (41712), name4 (38555), name3 (33934), 「ke (30814), firstaddress (16755), 当無 (15898), name2 (13214), 索出 (12433), adr (12329), 無") (11568), 数デ (9229), 当デ (7942), 該当 (7637), 抜粋 (7548), ト「 (7293), key (7262), select (6353), xlformulas (5775), searchdirection (5767), integer (5189), をペ (4948), xlnext (4771), 選択 (4728), searchorder (4570), 処方 (4352), cutcopymode (4302), selection (4196), 当す (4131), xlbyrows (4050), activecell (3964)
- 『検索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）... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/200205/20020514143945.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97032 documents and 608010 words.
訪問者：