プロが教える店舗＆オフィスのセキュリティ対策術

おしえて

VBA キーと項目が重複する場合の集計方法

解決済

  • 質問者：Takig
  • 質問日時：
  • 回答数：9件

お世話になります。
VBAの初心者です。あるソフトから、エクセルファイルにダウンロードした後、長さ0の文字列の削除や、重複箇所を色付けするなどの作業は行えたのですが、添付表の左から右の表の様にする、マクロを完成することができません。
添付表は、例として示させていただきました。
”矢印左側”　が元データです。
実際には、G列にサイズ、K列に品名が入力されております。現時点で行数は、230行、
列は、B列からN列まで、文字や数値が入力されております。今後、行数は増えますが、列数はふえません。同じシートのP列以降に、出力結果を表示させたいと考えております。
色々とネット検索をして、品名の重複数をDictionaryを用いて得られたのですが、サイズの重複を品名と紐づけして、サイズごとの件数を、矢印右側の表の様に集計することができません。”矢印右側”の2行目に示してあるサイズは、変化するため、左側の元データから抽出したいと考えております。

しばらく、格闘してみたものの、どんな関数を用いて、どう処理するかが全く分からない状態です。
大変申し訳ないのですが、マクロにコメントを追加していただけると、初心者である私には、理解するうえで大変助かります。

お手数ですが、よろしくお願いします。

質問者からの補足コメント

  • 添付表を添付し忘れました。
    失礼いたしました。

    「VBA キーと項目が重複する場合の集計方」の補足画像1
      補足日時：2018/01/03 05:29
    通報する

  • めぐみん＿さん
    早速のご回答ありがとうございます。

    Dictionaryを2個使っても構わないです。　

    また、出力された時の順番は、品名をアルファベット順にソートし、なおかつ、品目に対応するサイズも連動させたいのですが。

    誤解してたら申し訳ないのですが、サイズの「重複数」は、みかんのサイズ1.5が何個あり、サイズ３が何個あるとカウントしたいのですが・・・

    また、画像は、ご指摘の通り、逆に書かれております。

    よろしくお願いいたします。

    No.2の回答に寄せられた補足コメントです。 補足日時：2018/01/03 07:17
    通報する

  • めぐみん＿さん
    ご指摘の通り、サイズ毎のカウントの合計が＜重複数＞（Q列にあたる値）』になります。

    また、『マクロの自動記録』の件は、調べてみます。ちなみに、私は、Excel2013を使用しております。

    よろしくお願いします。

    No.3の回答に寄せられた補足コメントです。 補足日時：2018/01/03 09:21
    通報する

  • うーん・・・

    Tom04さん
    回答ありがとうございます。
    しかしながら、頂いた、マクロ実行すると添付画像の様にL列からサイズ別データ出力されてしまいます。
    まだ、ステップインで細かい確認を行っていませんが、アドバイスをお願いします。

    「VBA キーと項目が重複する場合の集計方」の補足画像4
    No.4の回答に寄せられた補足コメントです。 補足日時：2018/01/03 11:20
    通報する

  • めぐみん＿さん

    もしお手数でなければ、是非、Dictionaryを使った方法をお教授ください。
    よろしくお願いいたします。

    No.5の回答に寄せられた補足コメントです。 補足日時：2018/01/03 11:22
    通報する

  • うーん・・・

    Tom04さん
    Sample2を実行してみましたが、結果は変わりません。
    L列か出力が開始されしまいます。
    また、実物のデータのK列は、アルファベットの文字列となっており、マクロを実行すると、P列に３行ほど数字が表示されるだけで、
    Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = _
    WorksheetFunction.Small(myRng, i)
    の部分で、
    実行時デラー'1004'
    WorksheetFunctionクラスのSmallプロパティを取得できません。
    のエラーが発生いたします。

    No.6の回答に寄せられた補足コメントです。 補足日時：2018/01/03 11:48
    通報する
通報する

この質問への回答は締め切られました。

質問の本文を隠す

A 回答 (9件)

No.9

※この回答は、“締め切られた質問への回答追加”として、2018/01/03 14:10に回答者の方よりご依頼をいただき、教えて!gooによって代理投稿されたものです。


----
回答ボタンを押す寸前に閉めきられてしまったようでした。
一応作成できたので遅ればせながら回答します。
System.Collections.ArrayListとDictionaryのコラボです。

Sub try()
　Dim SizeList, v, vv
　Dim mydic As Object
　Dim r As Range, rr As Range
　Dim i As Integer

　Set SizeList = CreateObject("System.Collections.ArrayList") ''.NET Frameworkへの参照
　Set mydic = CreateObject("Scripting.Dictionary")

　For Each r In Range("G2", Cells(Rows.Count, "G").End(xlUp))
If SizeList.IndexOf_3(r.Value) < 0 Then SizeList.Add (r.Value)
　Next

　SizeList.Sort

　Range("P1", Cells(1, Columns.Count)).EntireColumn.Delete
　With Range("P1:P2")
.Merge
.Value = "品名"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
　End With

　With Range("Q1:Q2")
.Merge
.Value = "重複数"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
　End With

　With Range("R1").Resize(, SizeList.Count)
.Merge
.Value = "サイズ"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
　End With

　For i = 0 To SizeList.Count - 1
Range("R2").Offset(, i).Value = SizeList(i)
　Next

　ReDim v(0 To SizeList.Count + 1)

　For Each r In Range("K2", Cells(Rows.Count, "K").End(xlUp))
If Not mydic.Exists(r.Value) Then mydic.Add r.Value, v

i = SizeList.IndexOf_3(r.Offset(, -4).Value) + 2
vv = mydic(r.Value)
vv(0) = r.Value
vv(1) = vv(1) + 1
vv(i) = vv(i) + 1
mydic(r.Value) = vv
　Next

　With Range("P3").Resize(mydic.Count, SizeList.Count + 2)
.Value = Application.Transpose(Application.Transpose(mydic.Items))
.Sort Key1:=Range("P3"), Order1:=xlAscending, Header:=xlGuess
.Offset(-2).Resize(.Rows.Count + 2).Borders.LineStyle = xlContinuous
　End With

　Set mydic = Nothing
　Set SizeList = Nothing
End Sub

以上
    • good
    • 0
    • 件
通報する

参考程度に

No.8ベストアンサー

  • 回答者： 30246kiku
  • 回答日時：

以下でどうなりますか



Dictionary は 2 つ使って

dic ･･･ Dictionary の２段構成
１段目キー：品名 ･･･ 縦に展開するもの
２段目キー：サイズ ･･･ 横に展開するもの
関連する値 ･･･ 今回は出現数

dicE ･･･ 横展開用途
キー：サイズ
値は後で設定 ･･･ そのサイズの列番号


Option Explicit

Public Sub Samp1()
　　Dim dic As Object, dicE As Object, dicW As Object
　　Dim vA As Variant, vK As Variant, v As Variant
　　Dim i As Long, j As Long, k As Long

　　Set dic = CreateObject("Scripting.Dictionary")
　　Set dicE = CreateObject("Scripting.Dictionary")

　　With ActiveSheet
　　　　k = .Cells(Rows.Count, "K").End(xlUp).Row
　　　　For i = 2 To k
　　　　　　vK = .Cells(i, "K").Value
　　　　　　v = .Cells(i, "G").Value
　　　　　　dicE(v) = Empty
　　　　　　If (dic.Exists(vK)) Then
　　　　　　　　Set dicW = dic(vK)
　　　　　　Else
　　　　　　　　Set dicW = CreateObject("Scripting.Dictionary")
　　　　　　End If
　　　　　　dicW(v) = dicW(v) + 1
　　　　　　Set dic(vK) = dicW
　　　　Next

　　　　ReDim vA(1 To dic.Count + 2, 1 To dicE.Count + 2)
　　　　vA(1, 1) = "品名"
　　　　vA(1, 2) = "重複数"
　　　　vA(1, 3) = "サイズ"
　　　　i = 2
　　　　j = 2
　　　　For Each v In mySort(dicE.Keys)
　　　　　　j = j + 1
　　　　　　dicE(v) = j
　　　　　　vA(i, j) = v
　　　　Next

　　　　For Each vK In dic.Keys
　　　　　　i = i + 1
　　　　　　vA(i, 1) = vK
　　　　　　Set dicW = dic(vK)
　　　　　　vA(i, 2) = WorksheetFunction.Sum(dicW.Items)
　　　　　　For Each v In dicW.Keys
　　　　　　　　vA(i, dicE(v)) = dicW(v)
　　　　　　Next
　　　　Next

　　　　Application.ScreenUpdating = False
　　　　.Columns("P").Resize(, .UsedRange.Columns.Count).Clear
　　　　With .Range("P1").Resize(i, UBound(vA, 2))
　　　　　　.Value = vA
　　　　　　With .Offset(2).Resize(i - 2)
　　　　　　　　.Sort .Cells(1), xlAscending, Header:=xlNo
　　　　　　End With
　　　　　　.HorizontalAlignment = xlCenter
　　　　　　.Columns(1).Offset(2).Resize(i - 2) _
　　　　　　　　.HorizontalAlignment = xlLeft
　　　　　　.Cells(1).Resize(2).Merge
　　　　　　.Cells(2).Resize(2).Merge
　　　　　　.Cells(3).Resize(, .Columns.Count - 2).Merge
　　　　　　.Borders.LineStyle = xlContinuous
　　　　End With
　　　　Application.ScreenUpdating = True
　　End With

　　Set dic = Nothing
　　Set dicE = Nothing
　　Set dicW = Nothing
End Sub


Private Function mySort(ByVal vA As Variant) As Variant
　　Dim v As Variant
　　Dim i As Long, k As Long

　　k = UBound(vA)
　　Do
　　　　v = Empty
　　　　For i = LBound(vA) To k - 1
　　　　　　If (vA(i) > vA(i + 1)) Then
　　　　　　　　v = vA(i)
　　　　　　　　vA(i) = vA(i + 1)
　　　　　　　　vA(i + 1) = v
　　　　　　　　k = i
　　　　　　End If
　　　　Next
　　Loop While (Not IsEmpty(v))
　　mySort = vA
End Function



この辺のやり方にはパターンがあって、覚えておくと便利かも
データ量が多くなっても、ソコソコ速い･･･かと、例えば以下とか

エクセルVBA内での計算について エクセルVBA内
https://detail.chiebukuro.yahoo.co.jp/qa/questio …
    • good
    • 0
    • 件
通報する
この回答へのお礼

30246kikuさん
ありがとうございました。
大変素晴らしいプログラムをご提示いただき、お礼の言葉もございません。
スピードも速く、やりたいことが完成しました。
ただ、サンプルデータですと、サイズが左から右に小さい順（1.5 2 3 4)に表示されるのですが、実データで試すと、サイズが左から右に大きい順 (4 3 2 1.5)の様に表示されてしまいます。表示の順番が逆になるのか、一点疑問です。

とにかく、短時間でこれだけのマクロを仕上げるられることに、驚きと感動！自分もそうなれたらと思いますが、無理でございます。

大変ありがとうございました。

通報する
お礼日時：2018/01/03 13:43

参考程度に

No.7

  • 回答者： tom04
  • 回答日時：

No.4・6です。



今までのコードは
Q1セルに「重複数」という項目名が入っているという前提のコードでした。
補足のようにL列から表示された！というコトはQ1セルの項目名はなかったというコトですね？

↓のコードにしてみてください。

Sub Sample3()
Dim i As Long, lastRow As Long, lastCol As Long
Dim c As Range, r As Range, myRng As Range

Application.ScreenUpdating = False
'//▼表示結果を一旦消去//
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
If lastRow > 1 Then
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
If lastCol < Range("R1").Column Then
lastCol = Range("R1").Column
End If
Set myRng = Union(Range(Cells(1, "R"), Cells(1, lastCol)), Range(Cells(2, "P"), Cells(lastRow, lastCol)))
myRng.ClearContents
Range("Q1") = "重複数"
End If
'▼「サイズ」を重複なしにR1セル以降に昇順に表示//
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
Set c = Range("P:P").Find(what:=Cells(i, "G"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Cells(Rows.Count, "P").End(xlUp).Offset(1) = Cells(i, "G")
End If
Next i
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
Set myRng = Range(Cells(2, "P"), Cells(lastRow, "P"))
For i = 1 To lastRow - 1
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = _
WorksheetFunction.Small(myRng, i)
Next i
'//▼「品名」をP列に重複なしに表示//
Range("K:K").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("P1"), unique:=True
'//▼ここから処理//
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
Set c = Range("P:P").Find(what:=Cells(i, "K"), LookIn:=xlValues, lookat:=xlWhole)
Set r = Rows(1).Find(what:=Cells(i, "G"), LookIn:=xlValues, lookat:=xlWhole)
With Cells(c.Row, "Q")
.Value = .Value + 1
End With
With Cells(c.Row, r.Column)
.Value = .Value + 1
End With
Next i
'//▼「品名」の昇順で並び替え（追加）//
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
With Range(Cells(1, "P"), Cells(lastRow, lastCol))
.Sort key1:=Range("P1"), order1:=xlAscending, Header:=xlYes
.Borders.LineStyle = xlContinuous '//←罫線操作なので不要かも・・・//
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　Dictionary（連想配列）を使って重複しないデータを格納する方法をお望みのようですね。
今から外出しますので、
帰宅後、時間と気力があれば連想配列の方も考えてみたいと思います。m(_ _)m
    • good
    • 0
    • 件
通報する
この回答へのお礼

Tom04さん

お時間大変ありがとうございました。
30246kikuさんより、Dictionaryを用いたマクロを頂きました。
Tom04さんより頂きました、マクロも自分なりに勉強させていただきます。
大変ありがとうございました。

通報する
お礼日時：2018/01/03 13:51

参考程度に

No.6

  • 回答者： tom04
  • 回答日時：

No.4です。



投稿後補足の
＞出力された時の順番は、品名をアルファベット順にソートし・・・
に気づきました。

お示しの画像では「品名」はアルファベットではありませんが、実際はアルファベットになっているというコトでしょうか？

前回のコードは消去し、↓のコードにしてみてください。

Sub Sample2()
Dim i As Long, lastRow As Long, lastCol As Long
Dim c As Range, r As Range, myRng As Range

Application.ScreenUpdating = False
'//▼表示結果を一旦消去//
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
If lastRow > 1 Then
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
If lastCol = Range("Q1").Column Then
lastCol = Range("R1").Column
End If
Set myRng = Union(Range(Cells(1, "R"), Cells(1, lastCol)), Range(Cells(2, "P"), Cells(lastRow, lastCol)))
myRng.ClearContents
End If
'▼「サイズ」を重複なしにR1セル以降に昇順に表示//
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
Set c = Range("P:P").Find(what:=Cells(i, "G"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Cells(Rows.Count, "P").End(xlUp).Offset(1) = Cells(i, "G")
End If
Next i
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
Set myRng = Range(Cells(2, "P"), Cells(lastRow, "P"))
For i = 1 To lastRow - 1
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = _
WorksheetFunction.Small(myRng, i)
Next i
'//▼「品名」をP列に重複なしに表示//
Range("K:K").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("P1"), unique:=True
'//▼ここから処理//
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
Set c = Range("P:P").Find(what:=Cells(i, "K"), LookIn:=xlValues, lookat:=xlWhole)
Set r = Rows(1).Find(what:=Cells(i, "G"), LookIn:=xlValues, lookat:=xlWhole)
With Cells(c.Row, "Q")
.Value = .Value + 1
End With
With Cells(c.Row, r.Column)
.Value = .Value + 1
End With
Next i
'//▼「品名」の昇順で並び替え（追加）//
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
With Range(Cells(1, "P"), Cells(lastRow, lastCol))
.Sort key1:=Range("P1"), order1:=xlAscending, Header:=xlYes
.Borders.LineStyle = xlContinuous '//←罫線操作なので不要かも・・・//
End With
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　最後の方に並び替えの操作を追加しています。m(_ _)m
この回答への補足あり
    • good
    • 0
    • 件
通報する

つらい・・・

No.5

回答が出たようですし、Dictionaryなど使ってややこしくするよりかは覚えやすいのではないでしょうか。


やっぱバージョンの違いが大きいのかもしれないですね。
この回答への補足あり
    • good
    • 0
    • 件
通報する
この回答へのお礼

めぐみんさん
お時間大変ありがとうございました。
30246kikuさんとTom04さんのお二方からアドバイスを頂きました。
お忙しい中、お期間を割いていただき、誠にありがとうございました。

通報する
お礼日時：2018/01/03 13:49

参考程度に

No.4

  • 回答者： tom04
  • 回答日時：

こんにちは！



横からお邪魔します。
行数が極端に多くないので、単純にループさせてもそんなに時間は要しないと思います。

一例です。
↓の画像のような配置になっているという前提です。
尚、結合セルがあると面倒なので、セルの結合はしていません。

Sub Sample1()
Dim i As Long, lastRow As Long, lastCol As Long
Dim c As Range, r As Range, myRng As Range

Application.ScreenUpdating = False
'//▼表示結果を一旦消去//
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
If lastRow > 1 Then
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
If lastCol = Range("Q1").Column Then
lastCol = Range("R1").Column
End If
Set myRng = Union(Range(Cells(1, "R"), Cells(1, lastCol)), Range(Cells(2, "P"), Cells(lastRow, lastCol)))
myRng.ClearContents
End If
'▼「サイズ」を重複なしにR1セル以降に昇順に表示//
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
Set c = Range("P:P").Find(what:=Cells(i, "G"), LookIn:=xlValues, lookat:=xlWhole)
If c Is Nothing Then
Cells(Rows.Count, "P").End(xlUp).Offset(1) = Cells(i, "G")
End If
Next i
lastRow = Cells(Rows.Count, "P").End(xlUp).Row
Set myRng = Range(Cells(2, "P"), Cells(lastRow, "P"))
For i = 1 To lastRow - 1
Cells(1, Columns.Count).End(xlToLeft).Offset(, 1) = _
WorksheetFunction.Small(myRng, i)
Next i
'//▼「品名」をP列に重複なしに表示//
Range("K:K").AdvancedFilter Action:=xlFilterCopy, copytorange:=Range("P1"), unique:=True
'//▼ここから処理//
For i = 2 To Cells(Rows.Count, "G").End(xlUp).Row
Set c = Range("P:P").Find(what:=Cells(i, "K"), LookIn:=xlValues, lookat:=xlWhole)
Set r = Rows(1).Find(what:=Cells(i, "G"), LookIn:=xlValues, lookat:=xlWhole)
With Cells(c.Row, "Q")
.Value = .Value + 1
End With
With Cells(c.Row, r.Column)
.Value = .Value + 1
End With
Next i
Range("P1").CurrentRegion.Borders.LineStyle = xlContinuous
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　P列はK列の出現順になっていますので、
お示しの画像とは少し順番が変わっています。m(_ _)m
「VBA キーと項目が重複する場合の集計方」の回答画像4
この回答への補足あり
    • good
    • 0
    • 件
通報する

うーん・・・

No.3

No.2です。


補足に対して。

＞誤解してたら申し訳ないのですが、サイズの「重複数」は、みかんのサイズ1.5が何個あり、サイズ３が何個あるとカウントしたいのですが・・・
要するに表で見ると『サイズ毎のカウントの合計が＜重複数＞（Q列にあたる値）』になるのではないの？
もっと簡単に言えば『品名のカウント合計＝重複数』と画像では判断できるのですけど。
まぁ、私は『1.5 を 15 と見間違えて』はいましたが。

＞品名をアルファベット順にソートし、なおかつ、品目に対応するサイズも連動させたいのですが。
ん～、ここは基本書き出した後で並び替えを『マクロの自動記録』で出来る所と思います。
私が所持しているExcelは随分前のバージョンで、今のExcelなら機能的に変わるかも知れないですしね。
この回答への補足あり
    • good
    • 0
    • 件
通報する

No.2

＞品名の重複数をDictionaryを用いて得られたのですが、サイズの重複を品名と紐づけして、サイズごとの件数を



"品名"_"サイズ"をキーにしてカウントを取れば、同じ品名でサイズの違う件数を求めるのは楽なのです。
問題は書き出す際に『事前にサイズの種類をどう求めるか？』でしょうね。
まぁ、Dictionaryを２個使っても構わないとかなら可能かもですけど。
ただ順番は『出てきた順』で良いのでしょうかね？
『重複数』ってのは要するに『サイズ』に書き出された値をSUM関数で求めれば良いだけでしょうしね。

＞実際には、G列にサイズ、K列に品名が入力されております。
画像とは逆に書かれている訳ですね。
この回答への補足あり
    • good
    • 0
    • 件
通報する

No.1

  • 回答者： tatsu99
  • 回答日時：

「添付表」を添付してください。

    • good
    • 0
    • 件
通報する

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう！

Q質問する（無料）

関連するカテゴリからQ&Aを探す

ページトップページトップ

Q質問する（無料）

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

おすすめ情報