[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『INDEXとMATCHのようなマクロ』(マクロ初心者)
Sheets("対比表") 品番がどのグループに属しているかの対比表(約3000件) A列 B列 1 グループ名 品番 2 GroupA 2020001 3 GroupB 2020002 4 GroupB 2020003 5 GroupC 2020004 6 GroupC 2020005 7 GroupC 2020006
Sheets("データ") 会社ごとの購入品番(10000件) A列 B列 1 会社名 品番 2 会社あ 2020001 3 会社あ 2020002 4 会社あ 2020003 5 会社あ 2020004 6 会社あ 2020005 7 会社い 2020001 8 会社い 2020002 9 会社い 2020003 10 会社い 2020004 11 会社う 2020001
Sheets("集計") グループ別・会社別での売り上げ件数 A列 B列 C列 D列 E列 (35列くらい) 1 会社あ 会社い 会社う 会社え・・・・・ 2 GroupA 1 1 1 3 GroupB 2 2 0 4 GroupC 2 2 0 5 GroupD 6 GroupE 7 GroupF ( 100行くらい)
マクロの質問です。 対比表シートを見比べてグループごとの会社別売り上げ表を作りたいと思っています。 かなり件数が多いのでマクロが希望です。 集計のシートには、1行目のタイトル、A列は記載済みです。 コードを書いていただけたら助かりますが、ヒントだけでも教えていただけたら助かります。
よろしくお願いいたします。
< 使用 Excel:Excel2016、使用 OS:Windows10 >
(マナ) 2020/05/07(木) 19:33
(マナ) 2020/05/07(木) 19:49
こんばんは! ちょっと書いてみました。。。 止まらないと思いますが、、駄目な時があったらごめんちゃいです。。。(^^; 一応、、こんな感じになりました。
会社あ 会社い 会社う GroupA 1 1 1 GroupB 2 2 GroupC 2 1
Option Explicit Sub てすと() Dim MyDicA As Object Dim MyDicB As Object Dim 対比表 As Variant Dim データ As Variant Dim x As Variant Dim y As Variant Dim q As Variant Dim p As Variant Dim Group() As Variant Dim 会社名() As Variant Dim i As Long Dim j As Long Dim n As Long Dim k As Long Set MyDicA = CreateObject("Scripting.Dictionary") Set MyDicB = CreateObject("Scripting.Dictionary") With Sheets("対比表") 対比表 = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value End With n = 1 ReDim Group(n) For i = LBound(対比表, 1) + 1 To UBound(対比表, 1) MyDicA(対比表(i, 2)) = 対比表(i, 1) q = Application.Match(対比表(i, 1), Group, 0) If IsError(q) Then Group(n) = 対比表(i, 1) n = n + 1 ReDim Preserve Group(n) End If Next With Sheets("データ") データ = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value End With k = 1 Group = Application.Transpose(Group) For i = LBound(データ, 1) + 1 To UBound(データ, 1) If MyDicA.Exists(データ(i, 2)) Then MyDicB(MyDicA(データ(i, 2)) & "," & データ(i, 1)) = MyDicB(MyDicA(データ(i, 2)) & "," & データ(i, 1)) + 1 p = Application.Match(データ(i, 1), Application.Index(Group, 1, 0), 0) If IsError(p) Then k = k + 1 ReDim Preserve Group(LBound(Group, 1) To UBound(Group, 1), 1 To k) Group(1, k) = データ(i, 1) End If End If Next For i = LBound(Group, 1) + 1 To UBound(Group, 1) For j = LBound(Group, 2) + 1 To UBound(Group, 2) Group(i, j) = MyDicB(Group(i, 1) & "," & Group(1, j)) Next Next With Sheets("集計") .Cells.Clear .Range("A1").Resize(UBound(Group, 1), UBound(Group, 2)).Value = Group End With Set MyDicA = Nothing Set MyDicB = Nothing Erase 対比表, データ, Group End Sub (SoulMan) 2020/05/07(木) 20:52
> 集計のシートには、1行目のタイトル、A列は記載済みです。
全ての会社名、グループ名が書かれている前提で書いてます。
参考に Sub Test() Dim HinDic As Object, ComDic As Object, GroDic As Object Dim C As Range, v As Variant Dim i As Long, j As Long
Set HinDic = CreateObject("Scripting.Dictionary") Set ComDic = CreateObject("Scripting.Dictionary") Set GroDic = CreateObject("Scripting.Dictionary") With Sheets("対比表") For Each C In .Range("A2", .Cells(Rows.Count, "A").End(xlUp)) HinDic(C.Offset(, 1).Value) = C.Value Next End With With Sheets("集計") For Each C In .Range("B1", .Cells(1, Columns.Count).End(xlToLeft)) ComDic(C.Value) = C.Column - 1 Next For Each C In .Range("A2", .Cells(Rows.Count, "A").End(xlUp)) GroDic(C.Value) = C.Row - 1 Next With .Range("A1").CurrentRegion ReDim v(1 To .Rows.Count - 1, 1 To .Columns.Count - 1) End With End With With Sheets("データ") For Each C In .Range("A2", .Cells(Rows.Count, "A").End(xlUp)) i = ComDic(C.Value) j = GroDic(HinDic(C.Offset(, 1).Value)) v(j, i) = v(j, i) + 1 Next End With Sheets("集計").Range("B2").Resize(UBound(v), UBound(v, 2)).Value = v Set HinDic = Nothing Set ComDic = Nothing Set GroDic = Nothing End Sub
(ピンク) 2020/05/07(木) 22:01
Set HinDic = Nothing Set ComDic = Nothing Set GroDic = Nothing
3行、追加しました。
(ピンク) 2020/05/07(木) 23:59
さっそくありがとうございます。 ピンクさまのコードでうまくいきました。
SoulManさまのコードですると、横にずらーっと 会社あ 会社あ 会社あ 会社い 会社い・・・ というように会社の数だけ並ぶ形になりました。でも結果の数値は取れておりました。
ありがとうございます。 確かに、マナさまの仰る通り、初心者なので理解がむつかしく、
With .Range("A1").CurrentRegion ReDim v(1 To .Rows.Count - 1, 1 To .Columns.Count - 1) End With
このあたりで頭が混乱してしまいました。
ただすごく困っていたので、本当に助かりました!ありがとうございます。 (マクロ初心者) 2020/05/08(金) 01:24
おはようございます😃 すみませんね >横にずらーっと 会社あ 会社あ 会社あ 会社い 会社い・・・ ご提示されたデータですと並ばなかったと思うのですが 並ぶとなると p = Application.Match(データ(i, 1), Application.Index(Group, 1, 0), 0) ここが通っていることになると思います 良かったらでいいので並ぶ場合のデータを 少しでいいですからUPしてもらえませんか? 帰ったらあと学の為に勉強してみます あっそれとこれは見てませんでした >1行目のタイトル、A列は記載済みです。 すみません (SouMan) 2020/05/08(金) 06:02
Dim r As Range, c As Range, cc As Range Set r = Intersect(Sheets("集計").Range("A1").CurrentRegion, Range(Sheets("集計").Range("B2"), Sheets("集計").Cells(Rows.Count, Columns.Count))) r.ClearContents For Each c In r For Each cc In Sheets("データ").Range("A2:A" & Rows.Count).SpecialCells(2) If cc.Value = c.EntireColumn.Cells(1).Value Then If Sheets("対比表").Range("B:B").Find(cc.Offset(, 1).Value, , , xlWhole).Offset(, -1).Value = c.EntireRow.Cells(1).Value Then c.Value = Val(c.Value) + 1 End If Next cc Next c End Sub (mm) 2020/05/08(金) 14:27
こんばんは! もういらないでしょうけど、、↓ということなら難易度はぐぅぐぅ、、っと下がって >集計のシートには、1行目のタイトル、A列は記載済みです。 ↓みたいになりました。。。
Option Explicit Sub てすと() Dim MyDicA As Object Dim MyDicB As Object Dim 対比表 As Variant Dim データ As Variant Dim 集計 As Variant Dim i As Long Dim j As Long Set MyDicA = CreateObject("Scripting.Dictionary") Set MyDicB = CreateObject("Scripting.Dictionary") With Sheets("対比表") 対比表 = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value End With For i = LBound(対比表, 1) + 1 To UBound(対比表, 1) MyDicA(対比表(i, 2)) = 対比表(i, 1) Next With Sheets("データ") データ = .Range("A1", .Range("A" & Rows.Count).End(xlUp)).Resize(, 2).Value End With For i = LBound(データ, 1) + 1 To UBound(データ, 1) If MyDicA.Exists(データ(i, 2)) Then MyDicB(MyDicA(データ(i, 2)) & "," & データ(i, 1)) = MyDicB(MyDicA(データ(i, 2)) & "," & データ(i, 1)) + 1 End If Next With Sheets("集計") 集計 = .Range("A1").CurrentRegion.Value For i = LBound(集計, 1) + 1 To UBound(集計, 1) For j = LBound(集計, 2) + 1 To UBound(集計, 2) 集計(i, j) = MyDicB(集計(i, 1) & "," & 集計(1, j)) Next Next .Cells.Clear .Range("A1").Resize(UBound(集計, 1), UBound(集計, 2)).Value = 集計 End With Set MyDicA = Nothing Set MyDicB = Nothing Erase 対比表, データ, 集計 End Sub (SoulMan) 2020/05/08(金) 19:25
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.