[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『商品別項目一覧を 項目別の一覧に』(コオロギ)
お世話になります。
下記のような 表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.