[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『リスト形式の表から複数条件に合致する名前を抽出する』（みちる）
[[20210622114016]] 『Function関数で複数条件の文字列を抽出したい』（みちる）
↑以前こちらの質問でクロス集計表のシートから種類、地区、ランクが合致する品種を別ブックへ抽出するマクロを教えて頂きました。
今回、元表のクロス集計表がリスト形式に変わり、下記のような仕様になりました。
_|___A____|___B____|___C____|___D____|__ 1| | | | | 2| | | | | 3| 品種 |地区 |収穫量 |種類 | 4|紅玉 |A地区 |B |リンゴ | 5|紅玉 |B地区 |C |リンゴ | 6|紅玉 |C地区 |A |リンゴ | ・・・・データベースリスト型.xlsｘのシート「リスト」 7|北斗 |A地区 |D |リンゴ | 8|北斗 |B地区 |C |リンゴ | 9|幸水 |A地区 |A |ナシ | 10|あきづき|A地区 |B |ナシ | ・ ・ ・ 20000|ピオーネ|A地区 |B |ブドウ |
■上記の表から地区名と収穫量と種類に合致する品種を別ブックの下記のようなシートに抽出します。
__|___A____|___B______ |___C_______|___D____|__
1| | | | |
2| | | | |
3|A地区 |リンゴ |ブドウ |ナシ |
4|A | | |幸水 |
5|B |紅玉 |ピオーネ |あきづき| ・・・抽出先.xlsx の Sheet1
6|C |ふじ | | |
7|D |北斗 | | |
8|B,D |紅玉|北斗 |ピオーネ |あきづき|
9|A,D |北斗 | | |
| | | | |
| | | | |
【質問】教えて頂いてマクロをアレンジして、実行しましたが何も抽出されない結果となりました。どの部分を修正すればよいか教えて 頂けると幸いです。
Sub さんぷる_修正2()
Dim MyRNG As Range
Dim 列 As Long
Dim ws As Worksheet
With ActiveSheet
Set ws = Workbooks.Open(Filename:=ThisWorkbook.Path & "\データベースリスト型.xlsx").Worksheets("リスト")
On Error Resume Next
列 = Application.Match(.Range("A3").Value, ws.Range("B4:B20000"), 0)
On Error GoTo 0
If 列 = 0 Then Exit Sub
For Each MyRNG In .Range("B4:D9")
MyRNG.Value = 俺式関数壱(ws.Range("A4:D20000"), .Cells(3, MyRNG.Column).Value, .Cells(MyRNG.Row, "A").Value, 列)
Next MyRNG
End With
ws.Parent.Close SaveChanges:=False
End Sub
'==============================================================
Function リストへ抽出(表範囲 As Range, 種類 As String, ランク As String, 地区行 As Long) As String
Dim 地区 As Variant
Dim buf As String, tmpRNG As Range, 行 As Long
For 行 = 1 To 表範囲.Rows.Count
If 表範囲.Cells(行, 4).Value = 種類 Then
If UBound(Filter(Split(ランク, ","), 表範囲.Cells(地区行, 3).Value)) > -1 Then
buf = buf & 表範囲.Cells(行, 1).Value & "," & vbLf
End If
End If
Next 行
If buf <> "" Then buf = Left(buf, Len(buf) - 1)
俺式関数壱 = buf
End Function
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
×MyRNG.Value = 俺式関数壱(ws.Range("A4:D20000")
〇MyRNG.Value = リストへ抽出(ws.Range("A4:D20000")
×俺式関数壱 = buf 〇リストへ抽出 = buf
（みちる） 2021/06/30(水) 16:12
■２
「B,D」のような条件がなければ、TEXTJOIN関数とIF関数の組み合わせで目的を達することができるとおもいますが、その条件はマストなんですか？
https://qiita.com/567000/items/0adac97165821cfe9aaf
https://kokodane.com/2013_kan_015.htm
■３
自作関数でいくとした場合、素直に表の全行を巡回して、各行が条件に合致するのか見ていけばよいだけにおもいますが、それではダメなのですか？
（もこな２） 2021/06/30(水) 17:00
１の回答：
例で示した地区はA〜D地区までしかありませんが、本番用では地区が10000近くありますのでオートフィルタですと、とても時間がかかってしまうため自作関数を使用したいと考えております。
2の回答：
「B,D」のような条件はマストです。またその組み合わせも変化する可能性があります。
３の回答：
抽出が出来れば方法にこだわりはありません。私の知識で１から作ることが困難なため、教えて頂いたマクロをアレンジしてなんとか実現できないかと思い、質問致しました。
（みちる） 2021/06/30(水) 17:44
■４
＞私の知識で１から作ることが困難なため、
以前、提示したものは研究（理解）されたのでしょうか？
結局↓のようにしているわけですよね？
For 行 = 1 To 表範囲.Rows.Count
If 種類が合致しているか判定 Then
If （地区に対応した）ランクが（配列）のどれかに部分一致するか判定 Then
すべての条件に合致したらピックアップ
End If
End If
Next 行
つまり、全行を巡回して、
条件１：種類が合致していること 条件２：（地区に対応した）ランクを、Filter関数で調べたら何が返ってくること
という条件を満たす場合に、「buf」という変数に合体させてるわけです。
ならば、全行を巡回して、
条件１：地区が合致していること 条件２：種類が合致していること 条件３：ランクを、Filter関数で調べたら何が返ってくること
という条件を満たす場合に、「buf」という変数に合体させればよいだけではないですか？
「■３」はそういうことをコメントしたつもりです。
■５
＞オートフィルタですと、とても時間がかかってしまう
実際にどのくらいの差がでるのですか？ただの興味本位ですがおしえてください。
※自作関数のほうは「■４」を踏まえればご自身で対処出来ると思うので、オートフィルタのほうだけ作成してみました。
Sub オートフィルタ使用()
Dim x As Long, y As Long, buf As String, tmpRNG As Range
Dim 出力表 As Range
Set 出力表 = ThisWorkbook.Worksheets("Sheet1").Range("A3:D9")
With ThisWorkbook.Worksheets("リスト")
.AutoFilterMode = False
.Range("A3").AutoFilter
End With
With ThisWorkbook.Worksheets("リスト").AutoFilter.Range
For x = 2 To 出力表.Rows.Count
For y = 2 To 出力表.Columns.Count
.AutoFilter Field:=2, Criteria1:=出力表.Cells(1, 1).Value
.AutoFilter Field:=3, Criteria1:=Split(出力表.Cells(x, 1).Value, ","), Operator:=xlFilterValues
.AutoFilter Field:=4, Criteria1:=出力表.Cells(1, y).Value
buf = ""
For Each tmpRNG In Intersect(.Columns(1), .Columns(1).Offset(1)).Cells
If tmpRNG.EntireRow.Hidden = False Then buf = buf & tmpRNG.Value & "|"
Next tmpRNG
If buf <> "" Then 出力表.Cells(x, y).Value = Left(buf, Len(buf) - 1)
Next y
Next x
End With
■６
＞「B,D」のような条件はマストです。またその組み合わせも変化する可能性があります。
↓のようにランクを入力する列を複数設けてよいのであれば
____A___ ___B___ ___C___ ___D__ ___E__ __F____ 1 2 A地区 3 ランク1 ランク2 ランク3 リンゴ ブドウ ナシ 4 A 5 B 6 C 7 D 8 B D 9 A D
D4セルに↓のような数式を入力して必要な範囲にコピーすれば自作関数は不要でしょう、
=TEXTJOIN("|",TRUE,IF(
(リスト!$B$4:$B$10=$A$2)*
((リスト!$C$4:$C$10=$A4)+(リスト!$C$4:$C$10=$B4)+(リスト!$C$4:$C$10=$C4))*
(リスト!$D$4:$D$10=D$3),
リスト!$A$4:$A$10,""))
「■２」で言いたかったのはこういうことです。
（もこな２） 2021/07/01(木) 15:32
Function リスト型から抽出(表範囲 As Range, 地区 As String, 収穫量 As String, 種類 As String) As String
Dim 行 As Long, buf As String
For 行 = 1 To 表範囲.Rows.Count
If 表範囲.Cells(行, 3) <> 地区 Then
GoTo Continue
End If
If 表範囲.Cells(行, 4).Value <> 収穫量 Then
GoTo Continue
End If
If 表範囲.Cells(行, 2).Value <> 種類 Then
GoTo Continue
End If
buf = buf & 表範囲.Cells(行, 1).Value & "," & vbLf
Continue:
Next 行
リスト型から抽出 = buf
End Function
（抽出元）
_|___A____|___B____|___C____|___D____|__ 1| | | | | 2| | | | | 3| 品種 |地区 |収穫量 |種類 | 4|紅玉 |A地区 |B |リンゴ | 5|紅玉 |B地区 |C |リンゴ | 6|紅玉 |C地区 |A |リンゴ | ・・・・データベースリスト型.xlsｘのシート「リスト」 7|北斗 |A地区 |D |リンゴ | 8|北斗 |B地区 |C |リンゴ | 9|幸水 |A地区 |A |ナシ | 10|あきづき|A地区 |B |ナシ | ・ ・ ・ 20000|ピオーネ|A地区 |B |ブドウ |
（抽出先）
_|___A____|___B______ |___C_______|___D____|__ 1| | | | | 2| | | | | 3|A地区 |リンゴ |ブドウ |ナシ | 4|A | | |幸水 | 5|B |紅玉 |ピオーネ |あきづき| ・・・抽出先.xlsx の Sheet1 6|C |ふじ | | | 7|D |北斗 | | | 8|B,D |紅玉|北斗 |ピオーネ |あきづき| ←A8,9の条件が抽出されない。 9|A,D |北斗 | | | | | | | | | | | | |
（みちる） 2021/07/01(木) 15:38
更新が衝突したみたいでしたので、再掲しました。
（みちる） 2021/07/01(木) 15:43
Function 俺式関数壱(表範囲 As Range, 種類 As String, ランク As String, 地区列 As Long) As String
Dim buf As String, 行 As Long
For 行 = 1 To 表範囲.Rows.Count
If 表範囲.Cells(行, 2).Value = 種類 Then '★条件１：種類が合致してること
If 表範囲.Cells(行, 地区列).Value <> "" Then 'ランクが空欄だった時の対策
If UBound(Filter(Split(ランク, ","), 表範囲.Cells(行, 地区列).Value)) > -1 Then '条件２：（地区に対応した）ランクを、Filter関数で調べたら何かが返ってくること
buf = buf & 表範囲.Cells(行, 1).Value & "|"
End If
End If
End If
Next 行
If buf <> "" Then buf = Left(buf, Len(buf) - 1)
俺式関数壱 = buf
End Function
'--------------------------------------------------------------------------------------
Function 俺式関数弐(表範囲 As Range, 地区 As String, ランク As String, 種類 As String) As String
Dim buf As String, 行 As Long
For 行 = 1 To 表範囲.Rows.Count
If 表範囲.Cells(行, 2).Value = 地区 Then '★条件１：地区が合致してること
If 表範囲.Cells(行, 4).Value = 種類 Then '★条件２：種類が合致してること
If UBound(Filter(Split(ランク, ","), 表範囲.Cells(行, 3).Value)) > -1 Then '★条件３：ランクを、Filter関数で調べたら何かが返ってくること
buf = buf & 表範囲.Cells(行, 1).Value & "|"
End If
End If
End If
Next 行
If buf <> "" Then buf = Left(buf, Len(buf) - 1)
俺式関数弐 = buf
End Function
（もこな２） 2021/07/01(木) 17:16
4の回答：
俺式関数壱を全行巡回すれば出来ると薄々感じていましたが、修正しても出来ませんでしたので、全行巡回するマクロを調べて自作したものを提示した次第です。
５の回答：
質問の意図を理解していませんでした。オートフィルタをかけて手入力で抽出するものと思いました。
（質問）
俺式関数弐でテストしてみましたが、下記のワークシート関数で記述した場合、全て0が返されました。
B4=俺式関数弐([データベースリスト型.xlsx]リスト!$A$4:$D$11,MATCH($A$3,[データベースリスト型.xlsx]リスト!$B$3:$B$11,0),C$3,$A4)
さんぷる_修正2でテストした場合「ByRef引数の型が一致しません」とエラーが出て、『MyRNG.Value = 俺式関数弐(ws.Range("A4:D11"), 列,〜』の『列』が選択された状態になりました。エラーが出ないようにするにはどうしたらよいでしょうか。
Sub さんぷる_修正2()
Dim MyRNG As Range
Dim 列 As Long
Dim ws As Worksheet
With ActiveSheet
Set ws = Workbooks.Open(Filename:=ThisWorkbook.Path & "\データベースリスト型.xlsx").Worksheets("リスト")
On Error Resume Next
列 = Application.Match(.Range("A3").Value, ws.Range("B3:B11"), 0)
On Error GoTo 0
If 列 = 0 Then Exit Sub
For Each MyRNG In .Range("B4:D9")
MyRNG.Value = 俺式関数弐(ws.Range("A4:D11"), 列, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value)
Next MyRNG
End With
ws.Parent.Close SaveChanges:=False
End Sub
（みちる） 2021/07/02(金) 12:43
Function 俺式関数壱(表範囲 As Range, 種類 As String, ランク As String, 地区列 As Long) As String
For 行 = 1 To 表範囲.Rows.Count
'処理
Next 行
Function 俺式関数弐(表範囲 As Range, 地区 As String, ランク As String, 種類 As String) As String
For 行 = 1 To 表範囲.Rows.Count
'処理
Next 行
【どちらも】最初から全行巡回です。
■９
＞質問の意図を理解していませんでした。オートフィルタをかけて手入力で抽出するものと思いました。
言っても仕方ないのかもしれませんが、[[20210622114016]]の「（もこな２） 2021/06/24(木) 19:54」は読んでなかったのですか？
■10
＞俺式関数弐でテストしてみましたが、下記のワークシート関数で記述した場合、全て0が返されました。
少し確認させてください。↓は何を目的にしているのですか？
MATCH($A$3,[データベースリスト型.xlsx]リスト!$B$3:$B$11,0)
列 = Application.Match(.Range("A3").Value, ws.Range("B3:B11"), 0)
いずれも、なぜ求める必要があるのかわかりませんし、求めて何をしたいのかも理解できません。
前トピックの「表」シートでは、【地区ごとにランク（収穫量）の列が違う】からそれを求める必要があったわけですが、「リスト」シートでは、収穫量の列は固定されてますよね？
今一度問いますが、【以前、提示したものは研究（理解）されたのでしょうか？】
■11
＞数の型が一致しません
並べてみると↓のような関係性ですよね。
ws.Range("A4:D11") 列 .Cells(MyRNG.Row, "A").Value .Cells(3, MyRNG.Column).Value
↓ ↓ ↓ ↓
表範囲 As Range 地区 As String ランク As String 種類 As String
エラーの原因自体は、「Long型」値を「String型」に入れようとした為なので、文字列に変換すればエラー回避はできるでしょうが、「■10」で触れたようにそもそも根本的な間違いをしているので、そちらの対処をすべきでしょう。
（もこな２） 2021/07/02(金) 13:43
9の回答：失念しておりました。申し訳ありません。
10の回答：
ご指摘の通り、列が固定されているのでMACH関数を使う意味がありませんでした。失礼しました。下記のように修正しましたら抽出できるようになりました。
Sub さんぷる_修正2()
Dim MyRNG As Range
Dim ws As Worksheet
With ActiveSheet
Set ws = Workbooks.Open(Filename:=ThisWorkbook.Path & "\データベースリスト型.xlsx").Worksheets("リスト")
For Each MyRNG In .Range("B4:D9")
MyRNG.Value = 俺式関数弐(ws.Range("A4:D11"), .Cells(3, 1).Value, .Cells(MyRNG.Row, "A").Value, .Cells(3, MyRNG.Column).Value)
Next MyRNG
End With
ws.Parent.Close SaveChanges:=False
End Sub
（質問）「■５」の『Subオートフィルタを使用』の下記の部分が理解できないので教えて頂けますと幸いです。
For Each tmpRNG In Intersect(.Columns(1),.Columns(1).Offset(1)).Cells
If tmpRNG.EntireRow.Hidden = False Then buf = buf & tmpRNG.Value & "|"
Next tmpRNG
（みちる） 2021/07/02(金) 17:34
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.