ユーザーフォームに入力した文字列を検索、セルを貼り付けたい

###再度自分で考えてみます。
閲覧いただきありがとうございます。
・問題発生してまたヘルプを出す
・自己解決する
以上のどちらかになるまで、この質問はそのままにしておきます。
（情報の追加、修正依頼はお待ちしております…）

実現したいこと

ユーザーフォーム（文字列検索フォーム）作成
中身：テキストボックス、検索ボタン、キャンセルボタン

ユーザーフォームのテキストボックスに文字列を入力
→検索ボタン押す
→"Sheet1" を除くすべてのシート(のB列)からその文字列を含む（部分一致）セルを取得

"Sheet1" のA-C列に、取得したB列のセルの値と、隣り合うA,C列のセルの値を貼り付け

コード

ExcelVBA
1Private Sub SearchButton_Click()
2Stop
3    Dim Boxstr As String
4    Dim targetsheet As Worksheet
5    Dim foundCell As Range
6    Dim firstCell As Range
7    Dim r As Integer
8    
9    'テキストボックスに入力した値
10    Boxstr = Me.TextBox1.Text
11    
12    'テキストボックスの中身が空ならExit Sub
13    If Boxstr = "" Then Exit Sub 'if1
14    
15    'Sheet1以外を参照する
16    For Each targetsheet In Worksheets
17    If targetsheet.Name <> "Sheet1" Then 'if2
18    
19    'テキストボックスの値でセルを検索する
20    'あるはずなのに毎回Nothingになる
21    Set foundCell = targetsheet.Cells.Find _
22                    (what:=Boxstr)
23        'シート内に無い場合は次のシートから検索
24        'Thenのあとどうすれば？
25     If foundCell Is Nothing Then 'if3
26    '検索対象のセルがあったら
27    Else
28    'sheet1のA2~C2に貼り付け
29    Set firstCell = foundCell
30        foundCell.Resize(1, 3).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
31    Do
32        'セルがまだあったら
33        Set foundCell = Cells.FindNext(foundCell)
34        If foundCell.Address - firstCell.Address Then 'if4
35            Exit Do
36        Else
37            '以下１行ずつ下に貼り付け
38            foundCell.Resize(1.3).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
39        End If 'if4
40    '貼り付けのループ
41    Loop
42    End If     'if3'
43    End If 'if2
44    Next
45    Unload Me
46End Sub

エラー箇所

ExcelVBA
1If foundCell.Address - firstCell.Address Then 'if4

実行時エラー13
型が一致しません。

調べたこと

Office TANAKA - Excel VBA Tips[すべて検索する]
閲覧

丸投げの形になっておりましたら申し訳ありません。
よろしくお願いいたします。

kuma_kuma_

2020/09/29 07:29

ここは > Set foundCell = Cells.Find(what:=Boxstr) こうでは？ > Set foundCell = targetsheet.Cells.Find(what:=Boxstr)

ko_e

2020/09/29 07:40

確認いたします、少々お待ちください。

kuma_kuma_

2020/09/29 07:47

あ、あと同じシートで検索結果が複数の場合は想定しなくてよいのですか？

meg_

2020/09/29 07:49

> Nothingの場合、次のシートで検索をかけたい For Each targetsheet In Worksheetsで自動的に次のシートが処理されるんじゃないのですか？

ko_e

2020/09/29 07:51 編集

想定しています。これでは出来ないということですかね… 先にセルを見つけて配列に入れるなどした方がよいということでしょうか。

ko_e

2020/09/29 07:53

>>meg_様 If foundCell Is Nothing Then 'if3　のあと、どのように記述すれば次のシートに行くのかを考え中です。このままですとDoに飛んでしまいます。

kuma_kuma_

2020/09/29 07:55

Range.Find メソッド https://docs.microsoft.com/ja-jp/office/vba/api/excel.range.find https://www.tipsfound.com/vba/07030 Find メソッドは指定範囲で一番先に見つかったセル範囲の情報を返します。複数ある場合シートで検索したときの様に「次に」として再検索が必要になります。

kuma_kuma_

2020/09/29 07:57

値の単純な検索取得なら別の方法のほうが良いかと思います。検索は部分一致でよいのですか？

ko_e

2020/09/29 08:00

>>kuma_kuma_様はい、部分一致の予定です。 meg_様にご指摘いただいた点を含め、質問を編集させていただきます。

radames1000

2020/09/29 08:04

ちゃんとコードをおえてないのですが、Cells.FindNextがあるので同一シート内で複数合致も見ておられると思いました。

kuma_kuma_

2020/09/29 08:12

とりあえず方法だけ書いておきます。 (不明点があればおっしゃって下さい。VBAに書き出します。) シートに書かれている範囲はtargetsheet.UsedRangeで取得できますこの範囲の行列を順番にループ処理で検索値の判定は If targetsheet.cells(lngRow,lngCol).values like "*" & Boxstr &"*" Then みたいな書き方で部分一致で検索できますこれで値を取得して設定すれば良いのです。

ko_e

2020/09/29 08:22 編集

>>radames1000様質問を閲覧いただきありがとうございます。 FindNextで、取得したセルが最初のセルの場合は終了、最初のセルじゃないなら貼り付け… の予定でした。 >>kuma_kuma_様返信いただきありがとうございます。教えていただいた方法で、もう一度自分でチャレンジしてみます。この質問は自己解決にして、この問題で再度詰まった場合は別で質問を立てればよいでしょうか。

kuma_kuma_

2020/09/29 08:33

はい。頑張ってみて下さい。 > 別で質問を立てればよいでしょうか。内容が一緒ですから...あまり放置されないのであればしばらくこのままで (2重質問はおこられますので) しばらくしても「回答を待っています」で検索上位にすることができるそうです。自己解決できたら終了で良いかと思います。

ko_e

2020/09/29 08:37

>>kuma_kuma_様かしこまりました。しばらくこの質問はこのままにして、問題が発生した際は質問を編集して「回答を待っています」にしてみます。その時はまたお助けいただけますと幸いです。自己解決した際はその場合の考え方を記載して質問を閉じさせていただきます。

meg_

2020/09/29 08:45

既に解決済みかもしれませんが。｢このままですとDoに飛んでしまいます｣はこれで良いかと思います。現在のシート内の検索が終われば、次のシートの処理に移るかと思います。

ko_e

2020/09/29 08:50

>>meg_様 If foundCell Is Nothing Then 　　'if3 の、End If　の位置を修正いたしました。存在しない文字列で検索をかけましたところ、そのままプロシージャが終了いたしました。ご確認いただきありがとうございます。

行動規範の内容に同意します

回答1件

ベストアンサー

まず、インデント（字下げ）をきちんとするようにしましょう。
If と End If、 For と Next、Do と Loop の対応が読み取りやすくなります。

いちおう現状のコードをなるべく尊重して、間違っている部分のみを修正したコードが下記です。
サンプルを作成して動作確認済みです。
主な間違いはコメントしてあります。
ただ、修正点が多いのでコメントなしの部分もありますので、元のコードと見比べて、修正されている部分を確認してください。

vba
1Private Sub SearchButton_Click()
2    Stop
3    Dim Boxstr As String
4    Dim targetsheet As Worksheet
5    Dim foundCell As Range
6    Dim firstCell As Range
7    Dim r As Integer
8
9    Boxstr = Me.TextBox1.Text
10
11    If Boxstr = "" Then Exit Sub
12
13    For Each targetsheet In Worksheets
14        If targetsheet.Name <> "Sheet1" Then    'if2
15
16            'targetsheet.Cells.Find だとシート上のすべてのセルを検索します。
17            'B列を検索するなら
18            Set foundCell = targetsheet.UsedRange.Columns(2).Find _
19                (what:=Boxstr, LookAt:=xlPart) '部分一致はLookAt:=xlPart
20            
21            'Thenのあとどうすれば？→何もしなければ次のシートに行きます。
22            If foundCell Is Nothing Then
23                'ここは何もしない
24            Else
25                 Set firstCell = foundCell
26                foundCell.Resize(1, 3).Offset(0, -1).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
27                Do
28                    Set foundCell = targetsheet.UsedRange.Columns(2).FindNext(foundCell)
29                                       '↓マイナス(-)になっていたので型が一致しませんエラー
30                    If foundCell.Address = firstCell.Address Then     'if4
31                        Exit Do
32                    Else
33                        '以下１行ずつ下に貼り付け
34                        foundCell.Resize(1, 3).Offset(0, -1).Copy Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
35                    End If
36                Loop
37            End If
38        End If
39    Next
40    Unload Me
41End Sub
42

投稿2020/09/29 18:08

hatena19

総合スコア33715

ko_e

2020/09/30 01:02

ありがとうございます！！こちらのコードで試してみたところ、まさしく行いたいことが実現されました。質問する前にインデントすることを失念しておりました。（そもそも自分でEnd if の場所に困ってる時点でインデントしておくべきでした…）自力で行っていたらかなり時間がかかってしまったかもしれません… hatena19様に修正していただいた部分と自分が今まで考えていた部分の差異を見て、理解を深めます。コメントアウトでも教えていただき本当にありがとうございます。ここでお伝えするのはよくないかもしれませんが、 kuma_kuma_様をはじめとして、情報追加依頼でお知恵を貸してくださった方々もありがとうございます。

行動規範の内容に同意します