[[20200507185531]] 『INDEXとMATCHのようなマクロ』(マクロ初心者) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『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 >


マクロではないですが
https://www.crie.co.jp/chokotech/detail/301/

(マナ) 2020/05/07(木) 19:33


マクロならdictionaryを使うのが簡単なのですが
使ったことないと、完成品のコードをみても理解できないかもしれません。

(マナ) 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

Sub main()
    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.