[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで行列の条件に一致する値の取得』（ココア）
下記のような事をマクロでやりたいのですが、行き詰ってしまい教えて下さい。
＜元データシート＞
A B C D E
1
2 コード 種目 4月 5月 6月
3 A01 A 10 20 10
4 A01 B 5 10 5
5 A01 C 10 20 10
6 A02 A 20 20 10
7 A02 B 10 10 10
8 A02 C 5 10 10
9 A03 A 8 10 8
10 A03 B 2 5 6
11 A03 C 8 20 6
12 A01 A 10 20 10
13 A01 B 5 10 5
14 A01 C 10 20 10
＜貼り付け先シート＞
A B
1 B
2 5月
3
4 A01 10
5 A02 10
6 A03 5
やりたい事は、元データシートのコード列＆種目列と2行目の月が、貼り付け先シートのA4〜A6セルのコード 及び、A1セルの種目 及び A2セルの月が一致した場合、B4〜B6セルにその結果をかき出したいです。
元データシートの12〜14行目は3〜5行目と全く同じものが入っていますがこのように重複している場合もあります（ただし、全く同じ値が入っている）
これをマクロでやりたいのですが、関数を埋め込む方式なら下記で出来たのですが、For〜Nextや、Dictionaryを使って出来ないか試行錯誤していますがうまくいきません。教えて下さい。
＜関数埋め込み版＞
Sub 行列取得1()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("貼り付け先")
Set ws2 = Worksheets("元データ")
ws1.Range("B4:B6").Formula = "=INDEX(元データ!$A$2:$E$14,MATCH(貼り付け先!$A4&貼り付け先!$A$1,INDEX(元データ!$A$2:$A$14&元データ!$B$2:$B$14,),0),MATCH(貼り付け先!$A$2,元データ!$A$2:$E$2,0))"
End Sub
＜For〜Next版＞←エラーが出ます。
Sub 行列取得()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Worksheets("貼り付け先")
Set ws2 = Worksheets("元データ")
Dim i As Long
Dim ii As Long
Dim n As Long
Dim TargetRow As Long
Dim TargetCol As Long
'最終行の取得
Dim LastRow As Long
LastRow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastRow2 As Long
LastRow2 = ws1.Cells(Rows.Count, 1).End(xlUp).Row
'まずコードと種目行を取得する
For i = 3 To LastRow
For ii = 4 To LastRow2
If ws2.Cells(i, 1) = ws1.Cells(ii, 1) Then
If ws2.Cells(i, 2) = ws1.Cells(1, 1) Then
TargetRow = i '一致した行番号を取得する
Exit For
End If
End If
Next ii
Next i
'最終列の取得
Dim LastColumn As Long
LastColumn = ws2.Cells(2, Columns.Count).End(xlLeft).Row
'次に月の列を取得する
For i = 3 To LastColumn
If ws2.Cells(2, i) = ws1.Cells(2, 1) Then
TargetCol = i '一致した列番号を取得する
Exit For
End If
Next i
'結果を出力する
For ii = 4 To LastRow2
Cells(ii, 2) = Cells(TargetRow, TargetCol).Value
Next ii
End Sub
↑↑
下記でエラーになります。
LastColumn = ws2.Cells(2, Columns.Count).End(xlToLeft).columun
でもその前のループの仕方も色々違う気がするのですが。。
ご教授頂ければと思います。
また、このような場合はDictionary等でも可能なのでしょうか。
併せて教えて頂けますとうれしいです。
＜ 使用 Excel：Excel2010、使用 OS：unknown ＞
AdvancedFilterを用いて同様の形に出来るかもしれません。 検索値が無い等のエラー処理はしていませんので、あくまでもご参考程度に。
Sub sample()
With Worksheets("貼り付け先")
.Range("XFD1:XFD2").Value = WorksheetFunction.Transpose(Array("種目", .Range("A1")))
.Range("A4:B4").Value = Array("コード", .Range("A2"))
Worksheets("元データ").Cells(2, 1).CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, CriteriaRange:=.Range("XFD1:XFD2"), CopyToRange:=.Range("A4:B4"), Unique:=True
.Range("XFD1").CurrentRegion.Clear
.Rows(4).Delete
End With
End Sub
※すみません。一部修正 12:57 （豆腐） 2021/10/10(日) 12:46
私が最初に提示した「For〜Next版」の正しい書き方をご教授頂ける方がいらっしゃいましたら、
引き続き宜しくお願いいたします。
（ココア） 2021/10/10(日) 13:20
Match とか Filter などの機能を使わずに For〜Next でということですね。
まず、コードを書く時に、読みやすいコードになるように意識しましょう。
例えば、ws1 ws2 というような名前だと何のシートなのか分かりづらいですね。
私の感覚だと元データから貼り付け先に転記ということなので、ws1が元、ws2が先という気がしますが、 質問のコードでは逆になってますね。 そして、astRow2 が ws1 の最終行になってます。行は2なのにシートが1というのも混乱の元です。
例えば、下記のような変数名にすれば紛れがないですね。 （一例ですので、このへんはうまく工夫してください。）
元データ wsMoto 貼り付け先 wsSaki
元データ最終行 lastRowMoto 貼り付け先最終行 lastRowSaki
次に For〜Next ですが、 検索のループと出力のループが別になってますが、 出力は複数あるので、別にしたら、一つのデータしか出力できません。 TargetRow, TargetColにはそれぞれ一つの値しか格納できないので、 最後に検索された値が入っているだけですので。
For〜Next で検索して、一致したらその時に出力して、ループを抜ける、 というような処理にします。
Sub 行列取得()
Dim wsMoto As Worksheet
Dim wsSaki As Worksheet
Set wsMoto = Worksheets("元データ")
Set wsSaki = Worksheets("貼り付け先")
Dim i As Long
Dim ii As Long
'最終行の取得
Dim LastRowMoto As Long
LastRowMoto = wsMoto.Cells(Rows.Count, 1).End(xlUp).Row
Dim LastRowSaki As Long
LastRowSaki = wsSaki.Cells(Rows.Count, 1).End(xlUp).Row
'検索月の列番号を取得する
Dim TargetCol As Long
For i = 3 To wsMoto.Cells(2, Columns.Count).End(xlToLeft).Column
If wsMoto.Cells(2, i) = wsSaki.Cells(2, 1) Then
TargetCol = i '一致した列番号を取得する
Exit For
End If
Next i
Dim Syumoku
Syumoku = wsSaki.Cells(1, 1) '種目を取得
Dim Code As String
'貼り付け先の走査
For i = 4 To LastRowSaki
Code = wsSaki.Cells(i, 1) 'コードを取得
'元データを操作
For ii = 3 To LastRowMoto
'コードと種目が一致したら
If Code = wsMoto.Cells(ii, 1) And Syumoku = wsMoto.Cells(ii, 2) Then
wsSaki.Cells(i, 2) = wsMoto.Cells(ii, TargetCol) '該当月の列の値を出力
Exit For
End If
Next ii
Next i
End Sub
（hatena） 2021/10/10(日) 14:33
1部だけ
> '最終列の取得 > Dim LastColumn As Long > LastColumn = ws2.Cells(2, Columns.Count).End(xlLeft).Row
取得しているのは行
>LastColumn = ws2.Cells(2, Columns.Count).End(xlToLeft).columun
^^^^^^^
（pen） 2021/10/10(日) 14:38
ご提示のコードに対するアドバイスは他の方がして下さっているので、 「正しい書き方」かどうか分かりませんが、ご参考まで。
Sub test1()
'重複の削除機能を使う場合
Dim arr As Variant
Dim i As Long, cnt As Long
Dim buf As Long, rng As Range
With Worksheets("元データ")
With .Cells(2, 1).CurrentRegion
arr = Intersect(.Cells, .Offset(1)).Value
End With
Set rng = .Range("A2:E2")
End With
With Worksheets("貼り付け先")
buf = WorksheetFunction.Match(.Cells(2, 1).Value, rng, 0)
cnt = 3
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 2) = .Cells(1, 1).Value Then
cnt = cnt + 1
.Cells(cnt, 1).Value = arr(i, 1)
.Cells(cnt, 2).Value = arr(i, buf)
End If
Next i
.Cells(4, 1).CurrentRegion.RemoveDuplicates Columns:=Array(1, 2)
End With
End Sub
--
Sub test2()
'Dictionaryで重複を撥ねる場合
Dim arr As Variant
Dim i As Long
Dim buf As Long, rng As Range
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
With Worksheets("元データ")
With .Cells(2, 1).CurrentRegion
arr = Intersect(.Cells, .Offset(1)).Value
End With
Set rng = .Range("A2:E2")
End With
With Worksheets("貼り付け先")
buf = WorksheetFunction.Match(.Cells(2, 1).Value, rng, 0)
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, 2) = .Cells(1, 1).Value Then
On Error Resume Next
Dic.Add arr(i, 1), arr(i, buf)
On Error GoTo 0
End If
Next i
With .Cells(4, 1).Resize(Dic.Count)
.Value = WorksheetFunction.Transpose(Dic.keys)
.Offset(, 1).Value = WorksheetFunction.Transpose(Dic.Items)
End With
End With
End Sub
（豆腐） 2021/10/10(日) 15:17
最初のフィルタオプションの方は、
訂正前
.Range("XFD1").CurrentRegion.Clear
.Rows(4).Delete
訂正後
.Range("XFD1:XFD2").Clear
.Range("A4:B4").Delete shift:=xlUp
こうしておけば、使えましたでしょうか。 XFD1までデータが入っていたとしたら無理ですが・・・
もしかしてA7以下にデータがあるということですかね｡ そうすると､元データのコードはあくまでも3種類限定ということですね｡ でしたら､ Sub test1() '重複の削除機能を使う場合 の方は無視して下さい｡ ※15:57 加筆修正 （豆腐） 2021/10/10(日) 15:45
＞ For〜Next で検索して、一致したらその時に出力して、ループを抜ける、
大変勉強になります。元データと貼り付け先の行数が違うのでどのように変数を使って処理すれば良いのか…頭の中が混乱してしまっているのがそのままコードに表れてしまっていました(*_*;
じっくり教えて頂いた事を整理して、完全に理解できるように頑張りたいと思います。
分かりやすい変数名を指定する事もおっしゃる通りですね。
今回のまさに大きな混乱の原因がここにありました。
本当にありがとうございました。
pen様
ありがとうございます！
まだ勉強したてでこのようなケアレスミスを連発させているので、エラーを減らせるようにしていきたいと思います！
豆腐様
AdvancedFilterに加えて、Dictionaryまで教えて頂き大変ありがとうございます。 今回は、事例で端折ってしまっていますが、Ａ7以下にも何百行とデータが続きます。 かつ、元データにはあって貼り付け先には存在しないコード、その逆…と存在する為、教えて頂いた方法で試してみたところ、そのようなケースの場合はうまく出来ませんでしたが、配列等もこれから出来るようになりたいと思っているので、要所要所に参考になる書き方があり、大変勉強になりました。 色々ご親切にありがとうございました。
（ココア） 2021/10/10(日) 17:44
元データの行数×貼り付け先の行数分のセル参照をすることになりますので。
高速化の方法としては、セル範囲を配列にして、それを対象にループする。
あるいは、Dictionaryを使って検索する。
その両方を併用する。
などの方法があります。
実データで実行してみて、あまりに遅いなら、
まずは、私のコードについて理解できてから、上記の高速化の手段を検討されるといいでしょう。
（hatena） 2021/10/10(日) 21:06
今回の例でば、
１）「フィルター詳細設定」で作業セルに抽出
２）「統合」で、貼付先に並べ替えて転記
という２ステップの操作で実現可能です。
これをマクロにすると
Sub test()
Dim 元データ As Range
Dim 条件 As Range
Dim 抽出先 As Range
Dim 貼付先 As Range
Set 元データ = Worksheets("元データ").Range("A2").CurrentRegion
With Worksheets("貼り付け先")
Set 条件 = .Range("E1:E2")
条件.Value = Application.Transpose(Array("種目", .Range("A1").Value))
Set 抽出先 = .Range("G1:H1")
抽出先.Value = Array("コード", .Range("A2").Value)
Set 貼付先 = .Range("A4")
End With
元データ.AdvancedFilter xlFilterCopy, 条件, 抽出先, True
貼付先.CurrentRegion.Consolidate _
抽出先.CurrentRegion.Address(, , xlR1C1, True), xlSum, False, True
条件.Clear
抽出先.CurrentRegion.Clear
End Sub
（マナ） 2021/10/10(日) 22:58
セル範囲を配列にするのとDictionaryを使って検索を併用する場合のサンプルコードを書いてみました。 これでかなり高速化するはずです。
前回のコードを元に修正していますので、 前回のコードの意味を理解したうえで、 前回と今回を比べると、 どこをどのように配列やDictionaryに修正しているか分かると思います。
Sub 行列取得_dic()
Dim wsMoto As Worksheet
Dim wsSaki As Worksheet
Set wsMoto = Worksheets("元データ")
Set wsSaki = Worksheets("貼り付け先")
'元データと貼り付け先の表データを配列に格納。
Dim aryMoto
aryMoto = wsMoto.Cells(2, 1).CurrentRegion.Value
Dim arySaki
arySaki = wsSaki.Cells(4, 1).CurrentRegion.Resize(, 2).Value
'検索月の列番号の取得
Dim targetMonth As String
targetMonth = wsSaki.Cells(2, 1)
Dim i As Long
Dim TargetCol As Long
For i = 3 To UBound(aryMoto, 2)
If aryMoto(1, i) = targetMonth Then
TargetCol = i '一致した列番号を取得
Exit For
End If
Next i
'検索種目
Dim Syumoku As String
Syumoku = wsSaki.Cells(1, 1)
Dim dic As New Dictionary '要 Microsoft Scripting Runtime 参照設定
For i = 2 To UBound(aryMoto)
'種目が一致したら
If aryMoto(i, 2) = Syumoku Then
'コードをKeyに、検索月のデータをItemとして Dictionaryに追加
dic(aryMoto(i, 1)) = aryMoto(i, TargetCol)
End If
Next
Dim Code As String
For i = 1 To UBound(arySaki)
Code = arySaki(i, 1)
'DictionaryからコードをKeyにして検索した月データを貼り付け先配列の2列目に出力
arySaki(i, 2) = dic(Code)
Next i
'貼り付け先配列を貼り付け先セル範囲に出力
wsSaki.Cells(4, 1).Resize(UBound(arySaki), UBound(arySaki, 2)).Value = arySaki
End Sub
（hatena） 2021/10/10(日) 23:14
消えません。そのために作業セルおよび「統合」機能を利用しています。
（マナ） 2021/10/10(日) 23:25
最後の下記部分がまだ今いち理解出来ていないですが、今後理解を深めていきたいと思います。
For i = 1 To UBound(arySaki)
Code = arySaki(i, 1)
'DictionaryからコードをKeyにして検索した月データを貼り付け先配列の2列目に出力
arySaki(i, 2) = dic(Code)
Next i
'貼り付け先配列を貼り付け先セル範囲に出力
wsSaki.Cells(4, 1).Resize(UBound(arySaki), UBound(arySaki, 2)).Value = arySaki
ほんとご丁寧なご対応に感謝いたします。ありがとうございました。
（ココア） 2021/10/11(月) 09:17
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.