ExcelVBA フォームでデータ検索して一致したものを新しいシートへコピーする

VBA入門者です。
どなたか教えていただけないでしょうか。
とあるデータから、二つの項目の値で一致したもの（片方だけ指定の場合もあります）を
項目列（１行目）も含めてコピーして、新しく別のシートを追加して貼り付けたいです。

オートフィルタを使い単純にコピペしたい所ではありますが、エクセルに詳しくない方でも使えるように、検索フォームで２項目の値（テキスト）または１項目の値を入力して、検索ボタンを押す仕様にすることになりました。

当初はただ検索して値を見るだけと聞いていたので、検索フォーム内に一致したデータを表示するものを作成しました。
体裁などは後回しで、検索し表示する事ができる所まで確認したところで、
検索結果は新しいシートを追加し、そこへ項目列と一緒に貼り付けることに変更となりました。
検索するたびに新しいシートを増やすかたちです。シート名は「検索結果_日付と時間」で
できると尚良いです。

検索フォームで検索と結果表示の際は、ネットで検索したものも参考にして試行錯誤の上作成しましたが、（見栄えなどは手付かずです）
今回は中々条件に合うものがなく、ヒントが欲しいです。
どうぞよろしくお願いいたします。

現在はここまで作っております。


'検索を実行します。部分一致検索を行っています。

Private Sub CommandButton1_Click()

Dim lastRow As Long

Dim myData, myData2(), myno

Dim i As Long, j As Long, cn As Long



' If TextBox1.Value = "" Or TextBox2.Value = "" ThenEnd



'検索するデータを配列　myData　に格納しています。

With Worksheets("データ")

lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

myData = .Range(.Cells(1, 1), .Cells(lastRow, 15)).Value

End With



'配列　myData の中で検索で一致したデータを配列　myData2　に格納しています。

ReDim myData2(1 To lastRow, 1 To 14)

For i = LBound(myData) To UBound(myData)

If myData(i, 2) Like "*" & TextBox1.Value & "*" And myData(i, 4) Like "*" & TextBox2.Value & "*" Then

cn = cn + 1

myData2(cn, 1) = myData(i, 1)

myData2(cn, 2) = myData(i, 2)

myData2(cn, 3) = myData(i, 4)

myData2(cn, 4) = myData(i, 5)

myData2(cn, 5) = myData(i, 6)

myData2(cn, 6) = myData(i, 7)

myData2(cn, 7) = myData(i, 8)

myData2(cn, 8) = myData(i, 9)

myData2(cn, 9) = myData(i, 10)

myData2(cn, 10) = myData(i, 11)

myData2(cn, 11) = myData(i, 12)

myData2(cn, 12) = myData(i, 13)

myData2(cn, 13) = myData(i, 14)

myData2(cn, 14) = myData(i, 15)



End If

Next i



'検索で一致したデータをリストボックスに表示します。

With ListBox1

.ColumnCount = 14

.ColumnWidths = "30;70;70;70;70;70;70;70;70;70;70;70;70;70"

.List = myData2

End With



End Sub

質問者からの補足コメント

• 

  皆さま、ご回答くださりありがとうございます。
  現在までに教えていただいた内容で一先ずチャレンジしようと思っております。
  来週火曜日以降に続きに取り組みますので、どうぞよろしくお願いいたします。

    補足日時：2020/11/19 17:14

• 

  先ほどより作業を再開しました。
  が、間違えて木曜日に書いたものを消してしまい、、、顔面蒼白となっております。
  シートを最後に追加するのと、シートの名前と・・・
  今からもう一度そこからやり直します。
  せっかく、いろいろ教えていただいたのに今は試すことができません。
  復旧したら戻ってまいります。申し訳ありません。

    補足日時：2020/11/24 13:46

No.6 回答者： ママチャリ 回答日時： 2020/11/19 21:38

なかなかシュールなコードですが、せっかく、ここまで作ったのに、もったいないですね！！

そこで、こんなUIはいかがですか？

「ボタン１をクリックすると抽出結果がリストに表示され、その結果を見て、OKならば、ボタン2をクリックして新規シートに書き出す。OKでない場合は、条件を訂正して、もう一回！！」みたいな。

それで良ければ、ボタン2を配置して、こんなコードを書いて出来上がりです（現在のコードは修正不要です）。

Private Sub CommandButton2_Click()
Sheets("雛型").Copy After:=Sheets(Worksheets.Count)
Range("A2").Resize(ListBox1.ListCount, ListBox1.ColumnCount) = ListBox1.List
End Sub

ちなみに、「データ」シートって、罫線とか書式設定とか無いんですか？
上記サンプルは、「雛型」シートをコピーして新規シートを作成しているので、お好きな雛形をご用意ください。

この回答へのお礼

ご回答ありがとうございます。
色々なサイトから学び、つぎはぎ状態のコードです…。
別の方法を教えてくださり勉強になります。
今のものがある程度形になりましたら試してみたいと思います！

お礼日時：2020/11/24 14:35

No.5 回答者： fujillin 回答日時： 2020/11/19 18:11

No3です

細かな内容がよくわかりませんが、全体としてはこんな感じでしょうか。
・元データの範囲は「A:O」列と仮定しており、
・一行目には必ず項目タイトルが入っているものと仮定しています
・新シートの1、2行目をフィルタオプションで使用し、抽出後に削除しています

Dim sh As Worksheet, rg As Range

Set sh = Worksheets("データ")
Set rg = Range(sh.cells(1, 1), sh.cells(Rows.Count, 1).End(xlUp)).Resize(, 15)

With Worksheets.Add(after:=Worksheets(Worksheets.Count))
　.Name = "検索結果_" & Format(Date, "yyyymmdd_") & Format(Time, "hhmmss")
　rg.Rows(1).Copy .cells(1, 1)

　.cells(2, 2).Value = "*" & TextBox1.Value & "*"
　.cells(2, 4).Value = "*" & Textbox2.Value & "*"

　rg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=.Range("B1:D2"), _
　CopyToRange:=.Range("A3"), Unique:=False

　.Range("1:2").Delete
End With

この回答へのお礼

詳しく教えてくださりありがとうございます。
今のものがある程度できたら、試してみます！
簡単な方法でできるよう、勉強していきたいと思います。

お礼日時：2020/11/24 14:33

No.4 回答者： tatsumaru77 回答日時： 2020/11/19 16:55

myData = .Range(.Cells(1, 1), .Cells(lastRow, 15)).Value

ですが、これだと項目行（1行目）を含んでいますが、
1行目も検索対象にするのでしょうか？

myData = .Range(.Cells(2, 1), .Cells(lastRow, 15)).Value
が妥当だと思いますが、いかがでしょうか。

この回答へのお礼

ご回答ありがとうございます。
一行目は検索対象ではありません。教えてくださりありがとうございます。

お礼日時：2020/11/19 17:06

No.3 回答者： fujillin 回答日時： 2020/11/19 16:48

こんにちは

方法のアイデアのみですが・・・

＞新しいシートを最後尾に挿入し、日付と時刻に名前を変えるところまではできたのですが、
＞myDate2のデータをそのシートに貼り付け、項目行もコピペしたいのですが、やり方がわかりません。
「一行ずつチェックして、該当すれば転記する」というのがオーソドックスな方法かと思いますが、エクセル的にやるならという考えです。

新しいシートの作成はできているものとして…
オートフィルタ機能のフィルタオプションを利用して、抽出先を作成した新しいシートに指定すれば一気に抽出することが可能です。
具体的なコードに関しては、マクロの記録で同様の処理を記録してみれば、概ねの内容を理解できるものと思います。

フィルタオプションでは「*検索語*」形式のあいまい検索も利用できます。
検索用の条件設定をどこかの空セルに書き込む必要はありますが、それさえできれば、

元データ範囲.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=条件範囲, CopyToRange:=抽出セル範囲, Unique:=False

というような一文を実行することで抽出処理が全て完了してしまいますので、ある意味では「超簡単」とも言えると思います。

この回答へのお礼

ご回答ありがとうございます。
検索条件を入力するシートを用意して、
マクロを実行するボタンを配置するイメージでしょうか？
確かに簡単そうに思えますが、初心者なものでポワっとしか分からないので、できるかどうか頑張ってみたいと思います。
そして、せっかく教えていただいたのに申し訳ありませんが、
本日の業務時間が終了してしまったので、来週火曜日以降に試してみたいと思います。
引き続きよろしくお願いいたします。

お礼日時：2020/11/19 17:12

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2020/11/19 16:32

新規シートのシート名が判らないのでWorksheets("新規シート")にしてあります。

あなたのほうで、適切に変えてください。
以下でOKかと。
尚、データシートのC列が捨てられて、
新規シート：A,B=データシート：A,B
新規シート：C,N=データシート：D,O
と対応する前提で書いています。


Worksheets("新規シート").Cells.ClearContents
Worksheets("新規シート").Range("A1:B1") = Worksheets("データ").Range("A1:B1").Value
Worksheets("新規シート").Range("C1:N1") = Worksheets("データ").Range("D1:O1").Value
Worksheets("新規シート").Range("A2").Resize(cn, 14).Value = myData2

この回答へのお礼

ご回答、ありがとうございます。
検索項目の一つ目だけで抽出した結果は、教えていただいた内容で上手くできるようになりました！
が、二つ目の項目で上手く動かなくなってしまいます。
「C」だけで検索すると、コピーされて一見成功したように見えるのですが、
「C（その後数値）」のデータは拾ってくるのですが、
「C（その後に他のローマ字など）」と入っている項目を拾ってきません。
試しに、「CU」と入れると、教えていただいた最後の行が黄色くエラーになります。
（CURなど、該当するデータがあるのにもかかわらず）
今日はもう業務が終了になってしまうので、
来週火曜日以降にまたいじってみようと思います。
上手く行ってもいかなくても、またご報告いたします。
引き続きよろしくお願いいたします。

お礼日時：2020/11/19 17:12

No.1 回答者： tatsumaru77 回答日時： 2020/11/19 15:50

１回の検索ごとに１つのシートが増えて、問題ないのでしょうか？

最後に、保存しないで閉じる前提なら、それで良いかも知れませんが、
保存して閉じるとなると、シートが増えすぎたとき、どうやって削除するかが問題になるような気がします。
又、追加するシートは最後に（一番右側に）追加する予定ですか？

この回答へのお礼

ご質問ありがとうございます。
シートは増えて問題ありません。保存もする前提です。
いらないシートの削除は検索した人ができる前提となっております。（今の所は）
シートは一番右側に増やしていきます。
新しいシートを最後尾に挿入し、日付と時刻に名前を変えるところまではできたのですが、
myDate2のデータをそのシートに貼り付け、項目行もコピペしたいのですが、やり方がわかりません。
引き続きよろしくお願いいたします。

お礼日時：2020/11/19 15:58