[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロでマトリクス条件に一致する元データを拾いたい』（ぱんだ）
マクロで下記の事をやりたいです。
A列からD列に元データがあります。1行目は項目行です。
次に、条件表（マトリクス形式）があります。F列からJ列にあります。 F1セルから表が始まります。
この条件表のF列のNo.が、元データのA列のNo.と一致し、
条件表の1行目のあ、い、う、えが、元データのC列の種別を表しています。
この条件に則って、元データから一致する行を抽出したいです。抽出結果は、ToとCcで分けたいです。
条件表にToとかいてあるものは、該当する元データ行の情報をL列からO列に転記したい。1行目に項目名は予め入力してある。
条件表にCcととかいてあるものは、該当する元データ行の情報をQ列からT列に転記したい。1行目に項目名は予め入力してある。
To or Ccと書いてあるのに、元データに一致するものがない場合もありうる。その場合、転記するものがないので何もしない。
まず、元データを2から最終行までループして、次に条件表の縦方向と横方向のマトリクスをループで一つずつみていくイメージでしょうか。
元データの行が数百行あるので、例えば配列を使うとか何か良い方法がありましたら教えて欲しいです。
よろしくお願いいたします。
＜元データ＞
A B C D No. 分類 種別 キー 1 a あ A 1 a い B 1 b い C 2 a あ D 2 c い E 2 d う F 3 e い G 3 f う G 4 a あ A 4 a あ H 4 g い I 4 h う J 4 i え K 4 j え L
＜条件表＞
F G H I J No. あ い う え 1 To To 2 To To 3 Cc To To 4 Cc
＜Output：To＞
L M N O No. 分類 種別 キー 1 a あ A 2 c い E 3 f う G
＜Output：Cc＞
Q R S T No. 分類 種別 キー 3 e い G 4 i え K 4 j え L
＜ 使用 Excel：Microsoft365、使用 OS：Windows10 ＞
＞Cc には「え」がふたつあるのはなぜですか。
元データの最後の2行が、条件マトリクスのNo.4 かつ 「え」に一致するからです。
よろしくお願いいたします。
（ぱんだ） 2024/01/20(土) 21:38:40
一応例示通りになりました。
Sub sample()
Dim dat, cnd, arr_to(), arr_cc(), r, c
Dim i&, n&, m&, k&
[L1].CurrentRegion.Resize(, 9).Offset(1).ClearContents
dat = [A1].CurrentRegion
cnd = [F1].CurrentRegion
ReDim arr_to(1 To UBound(dat), 1 To 4)
ReDim arr_cc(1 To UBound(dat), 1 To 4)
For i = 2 To UBound(dat)
r = Application.Match(dat(i, 1), Application.Index(cnd, , 1), 0)
c = Application.Match(dat(i, 3), Application.Index(cnd, 1), 0)
If Not IsError(r) And Not IsError(c) Then
Select Case cnd(r, c)
Case "To"
n = n + 1
For k = 1 To 4
arr_to(n, k) = dat(i, k)
Next
Case "Cc"
m = m + 1
For k = 1 To 4
arr_cc(m, k) = dat(i, k)
Next
End Select
End If
Next
[L2].Resize(n, 4) = arr_to
[Q2].Resize(m, 4) = arr_cc
End Sub
（辰） 2024/01/20(土) 21:44:47
r = Application.Match(dat(i, 1), Application.Index(cnd, , 1), 0)
c = Application.Match(dat(i, 3), Application.Index(cnd, 1), 0)
の部分は、Index関数の説明を読むと、 INDEX(範囲,行番号,列番号) となっているので、
感覚的にcが行番号、rが列番号という感じがするのですが、このように取得するのですね。勉強してみます。
Bcc追加版でも無事にできました↓
大変ありがとうございました。
Sub sample_Bcc追加()
Dim dat, cnd, arr_to(), arr_cc(), arr_Bcc(), r, c
Dim i&, n&, m&, o&, k&
[L1].CurrentRegion.Resize(, 14).Offset(1).ClearContents
dat = [A1].CurrentRegion
cnd = [F1].CurrentRegion
ReDim arr_to(1 To UBound(dat), 1 To 4)
ReDim arr_cc(1 To UBound(dat), 1 To 4)
ReDim arr_Bcc(1 To UBound(dat), 1 To 4)
For i = 2 To UBound(dat)
r = Application.Match(dat(i, 1), Application.Index(cnd, , 1), 0)
c = Application.Match(dat(i, 3), Application.Index(cnd, 1), 0)
If Not IsError(r) And Not IsError(c) Then
Select Case cnd(r, c)
Case "To"
n = n + 1
For k = 1 To 4
arr_to(n, k) = dat(i, k)
Next
Case "Cc"
m = m + 1
For k = 1 To 4
arr_cc(m, k) = dat(i, k)
Next
Case "Bcc"
o = o + 1
For k = 1 To 4
arr_Bcc(o, k) = dat(i, k)
Next
End Select
End If
Next
[L2].Resize(n, 4) = arr_to
[Q2].Resize(m, 4) = arr_cc
[V2].Resize(o, 4) = arr_Bcc
End Sub
（ぱんだ） 2024/01/20(土) 22:29:17
解決したようなので、別案を。
こういうのはPower Queryが簡単です。 １.条件表を「ピボット解除」 ２.To（またはCc）でフィルター ３.元データと「クエリのマージ」 （マナ） 2024/01/20(土) 22:43:35
関数でも。
__A __B_ __C_ __D_ __E __F __G __H __I __J __K __L __M_ __N_ __O_ __P __Q __R_ __S_ __T_
1 No. 分類 種別 キー No. あ い う え No. 分類 種別 キー No. 分類 種別 キー
2 1 a あ A 1 To To 1 a あ A 3 e い G
3 1 a い B 2 To To 2 c い E 4 i え K
4 1 b い C 3 Cc To To 3 f う G 4 j え L
5 2 a あ D 4 Cc
6 2 c い E
7 2 d う F
8 3 e い G
9 3 f う G
10 4 a あ A
11 4 a あ H
12 4 g い I
13 4 h う J
14 4 i え K
15 4 j え L
[L2] =LET(list,$A$2:$D$500,key,take(list,,1)&"|"&take(drop(list,,2),,1),find,LET(a,tocol($G$2:$J$5&"|"&$F$2:$F$5&"|"&$G$1:$J$1),b,FILTER(a,LEFT(a,2)="To"),MID(b,4,LEN(b))),bool,map(key,LAMBDA(a,SUM(IFERROR(XMATCH(find,a),0)))),ret,FILTER(list,bool,""),ret) [Q2] =LET(list,$A$2:$D$500,key,take(list,,1)&"|"&take(drop(list,,2),,1),find,LET(a,tocol($G$2:$J$5&"|"&$F$2:$F$5&"|"&$G$1:$J$1),b,FILTER(a,LEFT(a,2)="Cc"),MID(b,4,LEN(b))),bool,map(key,LAMBDA(a,SUM(IFERROR(XMATCH(find,a),0)))),ret,FILTER(list,bool,""),ret)
（まる2021） 2024/01/20(土) 22:51:28
まる2021様
関数でも出来てしまう事に驚きました。ありがとうございます。
「その関数は正しくありません」とエラーが出てしまいますが、今使っているPCがoffice365対応でないからですかね。後日試してみます！
（ぱんだ） 2024/01/20(土) 23:08:16
下記、辰様に教えていただいたコードですが、
マトリクス条件に一致する行を、「To, Cc」ごとに転記するという部分で、転記する際に
もし1～4列目の全ての項目が重複していたら、リストへ転記するのは1行分だけにしたいです。（重複削除したい）
※実際の実例では1～4列ではなく、50列位あるので、
例えばIf文で、「 If arr_to(j, 1) = dat(i, 1) And arr_to(j, 2) = dat(i, 2) And arr_to(j, 3) = dat(i, 3) And arr_to(j, 4) = dat(i, 4) Then
のように確認していたら大変です。
何か一気に重複削除できるような方法あれば知りたいです。
また、行削除すると周りの列がずれてしまうので、重複削除した状態で貼り付けられるとベストです。
何か良い方法ありましたら、アドバイスお願いいたします。
Sub sample()
Dim dat, cnd, arr_to(), arr_cc(), r, c
Dim i&, n&, m&, k&
[L1].CurrentRegion.Resize(, 9).Offset(1).ClearContents
dat = [A1].CurrentRegion
cnd = [F1].CurrentRegion
ReDim arr_to(1 To UBound(dat), 1 To 4)
ReDim arr_cc(1 To UBound(dat), 1 To 4)
For i = 2 To UBound(dat)
r = Application.Match(dat(i, 1), Application.Index(cnd, , 1), 0)
c = Application.Match(dat(i, 3), Application.Index(cnd, 1), 0)
If Not IsError(r) And Not IsError(c) Then
Select Case cnd(r, c)
Case "To"
n = n + 1
For k = 1 To 4
arr_to(n, k) = dat(i, k)
Next
Case "Cc"
m = m + 1
For k = 1 To 4
arr_cc(m, k) = dat(i, k)
Next
End Select
End If
Next
[L2].Resize(n, 4) = arr_to
[Q2].Resize(m, 4) = arr_cc
End Sub
（ぱんだ） 2024/04/20(土) 00:26:00
「データ」 - 「重複の排除」を使って、予め重複を排除しておくのが簡便でしょう。 VBAで言えば、RangeオブジェクトのRemoveDuplicatesメソッドですね。
（xyz） 2024/04/20(土) 06:14:18
被っちゃった... 出力後に、重複削除すればいいのでは？ 具体的には、コードの最後に以下を追加。見出しがある場合は「Header:=xlYes」で
[L2].CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo
[Q2].CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo
（まる2021） 2024/04/20(土) 06:44:32
としたところ、結果が全て空白になってしまいます。
どこがおかしいのか分からず、、原因分かりますでしょうか。
＞予め重複を排除しておくのが簡便でしょう
これも考えましたが、元データは変えたくなく、結果のみ重複削除したいと考えています。
（ぱんだ） 2024/04/20(土) 07:41:13
＞＞予め重複を排除しておくのが簡便でしょう ＞これも考えましたが、元データは変えたくなく、結果のみ重複削除したいと考えています。
Microsoft365なのでUnique関数で重複を排除して配列に格納すればいいでしょう。
dat = [A1].CurrentRegion
↓
dat = WorksheetFunction.Unique([A1].CurrentRegion)
（hatena） 2024/04/20(土) 09:20:39
解決済みのようですが、こんな方法もあったかもしれません。 ・元データの最終列の右に、条件表から求めた「To,Cc,Bccの区分」列を追加(*) ・その追加列をもとに、フィルタオプションで結果の表にそれぞれ書き出す。 ・「重複を排除」する組み込みの設定も利用可能です。
(*)の部分は、条件表をもとに、No & vbTab & 種別をキーにしたdictionaryを作成しておけば簡単です。
列を追加するスペースがありません、とか 余分な列を追加したくありません、いうことなら残念ですけど。 なお、元データのコピーでもとっておかれるとよいと思いました。 （xyz） 2024/04/20(土) 10:03:33
xyz様
ありがとうございます。
今回はテーブルが入り組んでいるファイルのためスペース的に厳しそうですが、
とても勉強になります。
（ぱんだ） 2024/04/20(土) 12:12:49
xyzさんの作業列を使う案と同様のことを式でやる案を考えてました。
> xyz様 > ありがとうございます。 > 今回はテーブルが入り組んでいるファイルのためスペース的に厳しそうですが、 > とても勉強になります。
CurrentRegionでデータ表と条件表を取得出来ているということは、 データ表と条件表の間に空列があるということですよね。 それを作業列にすればいいかと思います。
作業列にTo,Cc,Bccの区分を式で出力 その列を条件にFILTER関数でデータを抽出 という方法です。 質問のデータなら、具体的には下記のような式になります。
作業列E列 E2セル: =XLOOKUP(C2,$G$1:$J$1,XLOOKUP(A2,$F$2:$F$5,$G$2:$J$5)) 下にコピー
Toの抽出結果 L2セル: =UNIQUE(FILTER(A2:D15,E2:E15="To"))
Ccの抽出結果 Q2セル: =UNIQUE(FILTER(A2:D15,E2:E15="Cc"))
実際のデータはもっと列数や行数が多いということなので、 このような式をVBAで設定して、抽出結果を値化して、作業列をクリアするということをコード化してみました。
---------------------------------------------
Public Sub SampleHatena()
Const kubuns = "To Cc Bcc" '区分
Dim rData As Range, rCond As Range, rWork As Range
Set rData = Cells(1).CurrentRegion
Set rData = Intersect(rData, rData.Offset(1)) 'データ範囲
Set rCond = Cells(1, rData.Columns.Count + 2).CurrentRegion
Set rCond = Intersect(rCond, rCond.Offset(1, 1)) '条件範囲
Set rWork = rData.Columns(rData.Columns.Count + 1) '作業列
'前の結果データ削除↓
rData.Offset(, rData.Columns.Count + rCond.Columns.Count + 3).Resize(, (rData.Columns.Count + 1) * (UBound(Split(kubuns)) + 1)).ClearContents
rWork.Value2 = "=XLOOKUP(C2," & rCond.Rows(0).Address & ",XLOOKUP(A2," & rCond.Columns(0).Address & "," & rCond.Address & "))"
Dim OutputCell As Range, kubun
Set OutputCell = rCond.Offset(, rCond.Columns.Count + 1).Cells(1)
For Each kubun In Split(kubuns)
OutputCell.Formula2 = "=UNIQUE(FILTER(" & rData.Address & "," & rWork.Address & "=""" & kubun & """))"
With OutputCell.CurrentRegion
.Value = .Value '抽出結果を値化
End With
Set OutputCell = OutputCell.Offset(, rData.Columns.Count + 1)
Next
rWork.ClearContents '作業列クリア
End Sub
---------------------------------------------
データ表や条件表の列が増えてもこのコードで対応できます。
こんな方法もあるということでご参考までに。
※2024/04/20 18:41 コード一部修正しました
（hatena） 2024/04/20(土) 15:16:49
Range.Address(External:=True) で外部参照(ブック名シート名を含む)アドレスを取得できますので別ブックでも参照できます。 少しの修正で対応可能です。
とりあえず下記の仕様とすると、
データペースと条件表のあるブックにマクロがある 一番目のシートにデータと条件はあり、レイアウトは質問と同じ
出力先のブック名 Output.xlsx 一番目のシートのA2セル以降に出力
------------------------------------------------------------------
Public Sub SampleHatena2()
Const kubuns = "To Cc Bcc" '区分
Dim rData As Range, rCond As Range, rWork As Range
With ThisWorkbook.Worksheets(1)
Set rData = .Cells(1).CurrentRegion
Set rData = Intersect(rData, rData.Offset(1)) 'データ範囲
Set rCond = .Cells(1, rData.Columns.Count + 2).CurrentRegion
Set rCond = Intersect(rCond, rCond.Offset(1, 1)) '条件範囲
Set rWork = rData.Columns(rData.Columns.Count + 1) '作業列
End With
rWork.Value2 = "=XLOOKUP(C2," & rCond.Rows(0).Address & ",XLOOKUP(A2," & rCond.Columns(0).Address & "," & rCond.Address & "))"
Dim OutputCell As Range, kubun
Set OutputCell = Workbooks("Output.xlsx").Worksheets(1).Range("A2")
'前の結果データ削除↓
OutputCell.Resize(rData.Rows.Count, (rData.Columns.Count + 1) * (UBound(Split(kubuns)) + 1)).ClearContents
For Each kubun In Split(kubuns)
OutputCell.Formula2 = "=UNIQUE(FILTER(" & rData.Address(External:=True) & "," & rWork.Address(External:=True) & "=""" & kubun & """))"
With OutputCell.CurrentRegion
.Value = .Value
End With
Set OutputCell = OutputCell.Offset(, rData.Columns.Count + 1)
Next
rWork.ClearContents
End Sub
------------------------------------------------------------------
（hatena） 2024/04/20(土) 18:46:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.