[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『商品別項目一覧を 項目別の一覧に』（コオロギ）
お世話になります。
下記のような 表1 商品ごとの項目一覧（「元データ」シート B5以下）があります。
これを 表2 項目ごとの商品一覧（「抽出」シート B2以下）に抽出するにはどうすればいいのでしょう？
よろしくお願いします。
＊表1最大値 項目名20 商品名800
■「元データ」シート
表1 商品ごとの項目一覧
A B 〜 H I J K L M N 〜
―――――――――――――――――――――――
4｜
5｜ 商品名 〜 項目A 項目B 項目C 項目D 項目E 項目F 項目G
6｜ 商品1 〜 A2 A6 A1 A5 A4
7｜ 商品2 〜 A1 A2
8｜ 商品3 〜 A2 A6
■「抽出」シート
表2 項目ごとの商品一覧
A B C D E F 〜
――――――――――――――――――――
1｜
2｜ 項目 商品一覧
3｜ A5 商品1
4｜ A7
5｜ A3
6｜ A1 商品1 商品2
7｜ A2 商品1 商品2 商品3
8｜ A4 商品1
9｜ A6 商品1 商品3
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
（マナ） 2020/08/09(日) 10:13
（コオロギ） 2020/08/09(日) 11:22
Option Explicit
Sub test()
Dim wsS As Worksheet
Dim wsD As Worksheet
Dim dic As Object
Dim v
Dim i As Long, k As Long
Dim 商品 As String, 項目
Dim m
Set wsS = Worksheets("元データ")
Set wsD = Worksheets("抽出")
Set dic = CreateObject("scripting.dictionary")
v = wsS.Range("B6").Resize(800, 26).Value
For i = 1 To UBound(v, 1)
商品 = v(i, 1)
If 商品 = "" Then Exit For
For k = 7 To UBound(v, 2)
項目 = v(i, k)
If Not IsEmpty(項目) Then
If Not dic.exists(項目) Then
Set dic(項目) = CreateObject("system.collections.arraylist")
End If
dic(項目).Add 商品
End If
Next
Next
For Each 項目 In dic.keys
m = Application.Match(項目, wsD.Columns("B"), 0)
If IsNumeric(m) Then
wsD.Range("C" & m).Resize(, dic(項目).Count).Value = dic(項目).toarray
End If
Next
End Sub
（マナ） 2020/08/09(日) 13:12
実行時エラー '-2146232576 (80131700)':
オートメーションエラーです。
と出ます。デバッグを開くと
Set dic(項目) = CreateObject("system.collections.arraylist")
が黄色く反転しています。
原因分かりますでしょうか？
◆念のため私の手順
alt+F11でvbaの画面を開き→挿入→標準モジュール→Option Explicit 〜 END Sub までをコピペ
→vbaの画面閉じる→開発→マクロ→テスト→実行
シート名、シート内データ すべてサンプル通りなんですが…。
◆「元データ」シートは商品名はB5から、項目名はH5からデータが入っていますがよろしいですね？
◆「抽出」シートB3以下には予め項目名を入力しておいてもよろしいですね？ （削除しても同じエラーでしたが…）
A B C D E F 〜
――――――――――――――――――――
1｜
2｜ 項目 商品一覧
3｜ A5
4｜ A7
5｜ A3
6｜ A1
7｜ A2
8｜ A4
9｜ A6
（コオロギ） 2020/08/09(日) 14:53
Sub test2()
Dim rngS As Range
Dim rngD As Range
Dim dic As Object
Dim v, w
Dim i As Long, k As Long
Dim 商品 As String, 項目 As String
Dim m
Set rngS = Worksheets("元データ").Range("B6").Resize(800, 26)
Set rngD = Worksheets("抽出").Range("B3").Resize(20)
Set dic = CreateObject("scripting.dictionary")
v = rngS.Value
w = rngD.Value
For i = 1 To UBound(v, 1)
商品 = v(i, 1)
If 商品 = "" Then Exit For
For k = 7 To UBound(v, 2)
項目 = v(i, k)
If 項目 <> "" Then
If Not dic.exists(項目) Then
m = Application.Match(項目, w, 0)
dic(項目) = m
Else
m = dic(項目)
End If
If IsNumeric(m) Then w(m, 1) = w(m, 1) & vbTab & 商品
End If
Next
Next
rngD.Value = w
rngD.TextToColumns DataType:=xlDelimited, Tab:=True, Other:=False
End Sub
（マナ） 2020/08/09(日) 15:09
（コオロギ） 2020/08/09(日) 18:16
Dim 商品 As String, 項目 As String を
Dim 商品 As String, 項目 As Variant
へ変更したのですがこれでよろしいでしょうか？
2.もしかしたら抽出シートは22行まででしょうか。それ以後が抽出されません。
「＊表1最大値 項目名20 商品名800」と書きましたが、一商品当たり項目名が20列という意味で
抽出シートの項目数最大値は20×800＝16000（行）となります
すいません、修正していただくなら元データの範囲を広げて
データ領域だけで言うと 元データシート H6〜DC805 でお願いします。（横100×縦800）
項目数最大値は100×800＝80000となります。
可能でしょうか。動作時間十秒程度で収まればいいのですが…。
3.今回元データの項目列はH列からですが、これをF列からにするにはどこを変えればよろしいでしょうか
4.私のパソコン（エクセル2019）では最初のコードでエラーが出ましたが、エクセル2016・2013でも同様に動作しますでしょうか（ご存知の範囲で）
（コオロギ） 2020/08/10(月) 10:49
Sub test3()
Dim rngS As Range
Dim rngD As Range
Dim dic As Object
Dim v, w
Dim i As Long, k As Long
Dim 商品 As String, 項目
'データ領域だけで言うと 元データシート H6〜DC805
Set rngS = Worksheets("元データ").Range("B6").Resize(800, 6 + 100)
'抽出シートの項目数最大値は20×800＝16000（行）
Set rngD = Worksheets("抽出").Range("B3").Resize(20 * 800)
Set dic = CreateObject("scripting.dictionary")
v = rngS.Value
w = rngD.Value
For i = 1 To UBound(w, 1)
If Not IsEmpty(w(i, 1)) Then dic(w(i, 1)) = i
Next
For i = 1 To UBound(v, 1)
商品 = v(i, 1)
If 商品 = "" Then Exit For
For k = 7 To UBound(v, 2) '★F列からなら 5
項目 = v(i, k)
If Not IsEmpty(項目) Then
If dic.exists(項目) Then
w(dic(項目), 1) = w(dic(項目), 1) & vbTab & 商品
End If
End If
Next
Next
rngD.EntireRow.ClearContents
rngD.Value = w
rngD.TextToColumns DataType:=xlDelimited, Tab:=True, Other:=False
End Sub
（マナ） 2020/08/10(月) 12:41
（コオロギ） 2020/08/10(月) 14:31
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.