質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.50%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

4213閲覧

複数リストボックスを選択してもデータを抽出したい

lq_hm_165912

総合スコア18

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2019/02/06 02:32

編集2019/02/06 02:41

前提・実現したいこと

オートフィルタでやった方が良い!と言われるかもしれませんが、PCに疎い方も操作するため、また似たようなフォーマットもまとめる必要があるため、抽出作業→計算をしたいと思っています。
まず抽出作業で戸惑っています。よろしくお願いします。

発生している問題・エラーメッセージ

Private Sub CommandButton1_Click()

'--------------------------------------
Dim N As Integer
Dim Clm As Integer

Clm = 1

'''セルへ転記
Worksheets("検索用").Select

For N = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(N) Then
Clm = Clm + 1
Cells(Clm, 1) = ListBox1.List(N)
End If
Next N

'''ListBox1の選択状態の解除

For N = 0 To ListBox1.ListCount - 1
ListBox1.Selected(N) = False
Next N
'-----------------------------------------------

Dim myRow1 As Long, myRow2 As Long '----Sheet1とSheet2のA列で最終行を捜します。 myRow1 = Sheets("抽出").Range("A" & Rows.Count).End(xlUp).Row myRow2 = Sheets("抽出2").Range("A" & Rows.Count).End(xlUp).Row '抽出先のクリアする Worksheets("抽出2").Range("A2:C" & myRow1).ClearContents '----フィルタオプションの設定で抽出します。 '----元データは抽出、抽出条件は検索用のA2:A10、抽出先は検索用G1です。 Sheets("抽出").Range("A2:C" & myRow1).AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=Sheets("検索用").Range("A2:A10"), _ CopyToRange:=Sheets("検索用").Range("G1"), _ Unique:=False

End Sub

エラーメッセージ 抽出されずに全てがペーストされてしまいます。 エラーは吐いていません。 本当は、セルに転記せず、複数選択したものが抽出されるようにしたいのですが、実力不足で噛ませています。

該当のソースコード

VBA

試したこと

フィルタオプション部分をいじりましたが見当違いのようでエラーになってしまっています。

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

ベストアンサー

本当は、セルに転記せず、複数選択したものが抽出されるようにしたいのですが、

そういうことなら、AutoFilter メソッドを使った方がいいかと。Criteria1引数に配列を渡せますので。

提示のコードでは、抽出先が Sheets("抽出2") なのか Sheets("検索用").Range("G1") なのか、不明確ですが、Sheets("抽出2").Range("A1") と仮定すると下記のコードでどうでしょう。

vba

1Private Sub CommandButton1_Click() 2 Dim N As Integer 3 Dim Cr As String 4 5 Application.ScreenUpdating = False 6 7 For N = 0 To ListBox1.ListCount - 1 8 If ListBox1.Selected(N) Then 9 Cr = Cr & " " & ListBox1.List(N) 10 End If 11 Next N 12 Cr = Trim(Cr) 13 If Cr = "" Then 14 MsgBox "リストから選択してください。" 15 Exit Sub 16 End If 17 18 Worksheets("抽出2").Range("G1").CurrentRegion.ClearContents 19 With Worksheets("抽出").Range("A1") 20 .AutoFilter Field:=1, _ 21 Criteria1:=Split(Cr), _ 22 Operator:=xlFilterValues 23 .CurrentRegion.Copy Worksheets("抽出2").Range("A1") 24 .AutoFilter 25 End With 26 27 Application.ScreenUpdating = True 28End Sub

追記

コメントのコードは繰り返しが多いので、配列を使うとコンパクトに記述できます。

vba

1Private Sub CommandButton1_Click() 2 Dim N As Long, i As Long 3 Dim Cr(1 To 3) As String 4 5 Application.ScreenUpdating = False 6 7 For i = 1 To 3 8 With Me("ListBox" & i) 9 For N = 0 To .ListCount - 1 10 If .Selected(N) Then 11 Cr(i) = Cr(i) & " " & .List(N) 12 End If 13 Next N 14 End With 15 Cr(i) = Trim(Cr(i)) 16 If Cr(i) = "" Then 17 MsgBox "リスト" & i & "から選択してください。" 18 Exit Sub 19 End If 20 Next i 21 Worksheets("①抽出結果").Range("A1").CurrentRegion.ClearContents 22 With Worksheets("抽出元データ").Range("A1") 23 For i = 1 To 3 24 .AutoFilter Field:=i, _ 25 Criteria1:=Split(Cr(i)), _ 26 Operator:=xlFilterValues 27 Next i 28 29 .CurrentRegion.Copy Worksheets("①抽出結果").Range("A1") 30 .AutoFilter 31 End With 32 33 Application.ScreenUpdating = True 34End Sub

投稿2019/02/06 06:14

編集2019/02/06 07:59
hatena19

総合スコア33620

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

lq_hm_165912

2019/02/06 06:38

ありがとうございます!! 以下のコードで出来ました。 このあとの集計でも躓いているので、試行錯誤してもわからなければまたこちらで質問させてください!! Private Sub CommandButton1_Click() Dim N As Integer Dim M As Integer Dim O As Integer Dim Cr As String Dim Dr As String Dim Er As String Application.ScreenUpdating = False For N = 0 To ListBox1.ListCount - 1 If ListBox1.Selected(N) Then Cr = Cr & " " & ListBox1.List(N) End If Next N Cr = Trim(Cr) If Cr = "" Then MsgBox "リストから選択してください。" Exit Sub End If For M = 0 To ListBox2.ListCount - 1 If ListBox2.Selected(M) Then Dr = Dr & " " & ListBox2.List(M) End If Next M Dr = Trim(Dr) If Dr = "" Then MsgBox "リストから選択してください。" Exit Sub End If For O = 0 To ListBox3.ListCount - 1 If ListBox3.Selected(O) Then Er = Er & " " & ListBox3.List(O) End If Next O Er = Trim(Er) If Er = "" Then MsgBox "リストから選択してください。" Exit Sub End If Worksheets("①抽出結果").Range("A1").CurrentRegion.ClearContents With Worksheets("抽出元データ").Range("A1") .AutoFilter Field:=1, _ Criteria1:=Split(Cr), _ Operator:=xlFilterValues .AutoFilter Field:=2, _ Criteria1:=Split(Dr), _ Operator:=xlFilterValues .AutoFilter Field:=3, _ Criteria1:=Split(Er), _ Operator:=xlFilterValues .CurrentRegion.Copy Worksheets("①抽出結果").Range("A1") .AutoFilter End With Application.ScreenUpdating = True End Sub
lq_hm_165912

2019/02/06 08:29

追記ありがとうございます。 今躓いていたのは、もう一つ加えたい条件のものをリストボックスに2列で配置して、1列目(とは言っても先頭2文字です)もオートフィルタをかけたいです。 リストボックスに配置まではいけたのですが .AutoFilter Field:=4, _ Criteria1:=Split(Fr), _ Operator:=xlFilterValues 追加したこの部分のCriteria部分をLeftで引っ張ろうにもどうにも上手くいかないです。 前手でFrをLeft関数で引けばよいのか調べながらやっています。 もしわかりましたら教えてくださいませ・・
hatena19

2019/02/07 04:54

何をしたいのか不明瞭です。 リストボックスに先頭2文字分のリストがあり、 それでシートのデータを、先頭部分一致でフィルターを掛けたいということでしょうか。 まずは、自分で AutoFilter の機能について調べましょう。 例えば、下記でいろいろな条件設定の例がのってます。部分一致の指定例もありますよ。 http://officetanaka.net/excel/vba/tips/tips155.htm
lq_hm_165912

2019/02/07 05:26

質問したままですみません!午前中になんとか自分で解決できました! おっしゃる通り部分一致や前方一致などを上手く活用したところ上手く抽出出来ました! 解決済にもかかわらず回答いただきありがとうございます!
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.50%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問