エクセルで該当項目の個数をカウントして表にするＶＢＡを組みたいです

ＶＢＡ初心者です。
sheet1のデータベースからある一定条件の項目だけを抜き出し、shett2にその個数をカウントする表を作るためのＶＢＡを作りたいのですが、初心者すぎて行き詰っています。
どうプログラミングしたらよいか教えてくださいm(--)m
（できれば今後の勉強のためにも、そのプログラムが何を実行しているのかの解説もつけていただけると助かります）

《sheet1》のデータベース
No 購入店　 購入日　購入者　購入物
1　 スーパー　4月　　　姉　　みかん
2　 スーパー　4月　　　弟　　りんご
3　 スーパー　5月　　　姉　　バナナ
4　 スーパー　5月　　　弟　　みかん
5　 スーパー　6月　　　姉　　りんご
6　 コンビニ　4月　　　弟　　バナナ
7　 コンビニ　5月　　　姉　　みかん
8 コンビニ　5月　　　弟　　りんご
9　 コンビニ　6月　　　姉　　バナナ
10　コンビニ　6月　　　弟　　みかん

【抽出条件】購入日が「5月以降」かつ購入者が「姉」
《shett2》の表示結果
　　　　　スーパー　コンビニ　合計
バナナ　　　1　　　　　1　　　2
りんご　　　1　　　　　0　　　1
みかん　　　0　　　　　1　　　1

※表の降順ですが上記のように
第一優先→合計数が多いもの順
第2優先→スーパーでの購入数が多いもの順
に並べ替えたいです。

No.5 回答者： WindFaller 回答日時： 2015/07/21 23:51

>頂いた両方のＶＢＡを勉強しながら比較してみようと思います。

#2のマクロは、書いた私でさえ、1ヶ月～2ヶ月で読めなくなってしまうものです。
でも、他の方は分かりませんが、マクロというものは、何か着想を持てば、そこから一気に作るものだという証拠かもしれません。

#4の方が易いです、いかにもExcel マクロらしいです。

マイクロソフトは、Excel VBAに対して、矛盾した方針があります。例えば、Ver.4マクロ関数は、もう使わないと言いながら、実際、それなしでは、VBAマクロは全面的には成立しません。Ver.5 のフォーム・コントロール・オブジェクトにしても、ユーザーに使わせたくないと言いながら、2007以降では、逆にActiveXコントロールよりも使用頻度が高くなってしまいました。

それから、一つだけ、私が書いて置かないといけないかもいけない事項があります。
一般のマニュアルや教本では出てこないものです。（それは、Microsoft側の見かけの方針に背くものだからです)

>Application.Transpose(.Range("D2", .Cells(Rows.Count, "D").End(xlUp)).Value)
この使い方は、97時代の古い書き方です。もう、ここの掲示板では、少なくとも、私が見た範疇では、こういうテクニックの意味を分かる人はいないようです。この書き方を間違いだという人さえいるのですから、VBAは終わっているのかもしれません。(VBカテゴリ内)

WorksheetFunction.Transpose と、Application.Transposeと、どう違うのか？
他のワークシートの組み込み関数をやっても、見た目の結果は同じです。
しかし、戻り値の範囲が違うのです。エラーを発生させた時に、WorksheetFunctionでは、マクロ（またはプロシージャ)全体がランタイム・エラーによって死んでしまいます。しかし、Application でやった時は、戻り値は、本来Variant型なので、エラー値として、変数で受け取ることが出来ますから、もし、エラーが発生する時は、IsErrorや数値が必要な場合は、IsNumericとすれば、エラー値と正しい戻り値とを区分けすることが出来ます。

サンプルコードです。
2番目のように、必ずしも間違いなく書けるとは限らないのです。

''---------------------
Sub TestFunction1()
Dim myArr(1 To 10)
Dim i As Long, j As Long
Dim myTarget As Long
Dim ret As Variant '←エラー値を入れるために、Variant 型にする
'-----配列の作成 -----
j = 1
For i = 10 To 1 Step -1
　 myArr(j) = i
　 j = j + 1
Next i
'-----配列の作成の終了 -------
'検索
Stop
myTarget = 20 'ここを入れ替える
　ret = Application.Match(myTarget, myArr, 0)
　If IsNumeric(ret) Then
　　MsgBox ret
　Else
　　MsgBox "エラーが発生しました。"
　End If
End Sub
''---------------------
Sub TestFunction2()
''On Error Resume 以降のコメントブロックを外したものが、補完スタイルです。
　Dim myArr(1 To 10) 'この場合は、デフォルトの0からでないほうが良い。
　Dim i As Long, j As Long
　Dim myTarget As Long
　Dim ret As Long 'ここは整数型のデータ型でも、Variant 型でもよい
　''-----配列の作成 -----
　j = 1
　For i = 10 To 1 Step -1
　　myArr(j) = i
　　j = j + 1
　Next i
　''-----配列の作成の終了 -------
　''検索
　Stop
　myTarget = 20 'ここに存在しない値を入れると、実行時エラーが発生します。
　'On Error Resume Next
　ret = WorksheetFunction.Match(myTarget, myArr, 0)
　'If Err() <> 0 Then
　'　MsgBox "エラーが発生しました。"
　'Else
　　MsgBox ret
　'End If
　'ret = 0 'ret を初期化しなくてはなりません。
　'On Error GoTo 0
End Sub
''---------------------

No.4 回答者： WindFaller 回答日時： 2015/07/18 19:00

zaki0124様

前回よりも、少しVBAらしさのあるものを、Excelスタイルで作りました。しかし、多少の癖が存在します。添付画像を見てください。評価は別として、数式はありませんから、負担は軽いです。

また、前回の「並べ替え」のプログラムは書き換えが必要になりました。

Sub SortData()
'No. 9022930-2
Dim Rng As Range
Dim r As Range
Dim r1 As Range
Dim r2 As Range
With ActiveSheet
'If .Range("A1") = "品名" Then ' ←ここの書き換えが必要です。次の行
　If .Range("A1").Value Like "品名*" Then


'//
Sub DataAnalysis2()
'No. 9022930-3
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim Rng As Range
Dim i As Long, j As Long, m As Long, n As Long
Dim buf As Variant
Dim num1 As Variant, num2 As Variant
Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Dim Lastrw As Long
Dim Data1 As Variant
Dim Data2 As Variant
Dim arData() As Long
　　'出力先の前のデータの消去
　　ws2.Range("A1").CurrentRegion.ClearContents
　　ws2.Range("A1:B1").Value = Array("購入物", "購入店")
　　With ws1
　　Set Rng = .Range("A1").CurrentRegion
　　If Rng.Cells.Count < 3 Then MsgBox "データが少なすぎます", vbExclamation: Exit Sub
　　'抽出条件のチェック
　　If .Cells(1, Rng.Columns.Count + 4).Value = "" Or _
　　　 .Cells(2, Rng.Columns.Count + 4).Value = "" Then
　　　 .Cells(1, Rng.Columns.Count + 4).Select
　　　 MsgBox "抽出条件を書き出してください", vbExclamation
　　　 Exit Sub
　　End If
　　Set Rng = Rng.Offset(, 1).Resize(, Rng.Columns.Count - 1)
　　'アドバンスフィルターの実行
　　Rng.AdvancedFilter _
　　Action:=xlFilterCopy, _
　　CriteriaRange:=.Range("I1:J2"), _
　　CopyToRange:=ws2.Range("A1:B1"), _
　　Unique:=False
　　End With
　　
　　With ws2
　　'出力したデータのカウント
　　Lastrw = .Cells(Rows.Count, 1).End(xlUp).Row
　　If Lastrw < 2 Then MsgBox "取得に失敗しました", vbExclamation: Exit Sub
　　.Range("A1:A" & Lastrw).Copy .Range("D1")
　　.Range("D1:D" & Lastrw).RemoveDuplicates Columns:=1, Header:=xlYes
　　
　　 Data1 = Application.Transpose(.Range("D2", .Cells(Rows.Count, "D").End(xlUp)).Value)
　　 'データ種類が1つの場合は、配列にならないので、配列に変更
　　 If IsArray(Data1) = False Then
　　　 buf = Data1
　　　 ReDim Data1(1 To 1)
　　　 Data1(1) = buf
　　　End If
　　 .Range("B1:B" & Lastrw).Copy .Range("E1")
　　 .Range("E1:E" & Lastrw).RemoveDuplicates Columns:=1, Header:=xlYes
　　　
　　　Data2 = Application.Transpose(.Range("E2", .Cells(Rows.Count, "E").End(xlUp)).Value)
　　　If IsArray(Data2) = False Then
　　　 buf = Data2
　　　 ReDim Data2(1 To 1)
　　　 Data2(1) = buf
　　　End If
　　 .Range("D1").CurrentRegion.ClearContents
　　
　　 ReDim arData(1 To UBound(Data1), 1 To UBound(Data2)) 'Data1,2 の配列型と合わせる
　　 'それぞれのデータは何番目か。重複が出たら、カウントを＋1
　　 For i = 2 To Lastrw
　　　 num1 = Application.Match(.Cells(i, 1).Value, Data1, 0)
　　　 num2 = Application.Match(.Cells(i, 2).Value, Data2, 0)
　　　 arData(num1, num2) = arData(num1, num2) + 1
　　 Next
　　 .Range("A1").CurrentRegion.ClearContents
　　 m = UBound(Data1): n = UBound(Data2)
　　 .Range("A1").Value = "品名／店"
　　 .Range("A2").Resize(m).Value = Application.Transpose(Data1)
　　 .Range("B1").Resize(, n).Value = Data2
　　 .Range("B2").Resize(m, n).Value = arData
　　 With .Cells(m + 2, 1)
　　　 .Value = "合　計"
　　　 .Offset(, 1).Resize(, n + 1).FormulaLocal = "=SUM(R2C:R[-1]C)"
　　 End With
　　 With .Cells(1, n + 2)
　　　 .Value = "合　計"
　　　 .Offset(1).Resize(m).FormulaLocal = "=SUM(RC2:RC[-1])"
　　 End With
　End With
　
End Sub
'///

この回答へのお礼

WindFaller様

いろいろとアドバイスしてくださり本当にありがとうございます。
頂いた両方のＶＢＡを勉強しながら比較してみようと思います。
もし解読していく中で、どうしてもわからないことがあればお聞きするかもしれませんが、その際はよろしくお願いいたします。

お礼日時：2015/07/21 21:13

No.3 回答者： WindFaller 回答日時： 2015/07/16 11:09

zaki0124様

>もしよろしければ全文公開していただけると嬉しいです。
了解しました。勝手を言って申し訳ありません。

繰り返すようで恐縮なのですが、この種のマクロは、決してVBAの勉強にはならないことはご承知ください。担当者が変わると無用の長物と化するマクロの類で、時々、会社などでは、見かけます。もしも、ちょっとプログラミングの腕が立つ人なら、これをADOスタイルに作り変えるはずです。しかし、こちらもこちらで、マクロがさっぱり手がつかなくなる可能性を秘めています。

結局、私の書いたマクロは、COUNTIFSなどが残っていますから、MOSのスペシャリストぐらいの力なら、関数で組めますから、30分程度で、修正し終えるはずという内容なのです。もちろん、ピボットテーブルも、その範疇に入ります。

今回のマクロのポイントは、単に関数をどうやって組み入れるかだけで、それ以上の発想もテクニックはありません。なのに、それ自体が複雑怪奇にさせているというのが、私の印象です。

なお、このご要望の
>第1優先→合計数が多いもの順
>第2優先→スーパーでの購入数が多いもの順（変更：どちらかが多いもの順)

一つのマクロで出力するためには、
>【抽出条件】購入日が「5月以降」かつ購入者が「姉」
が決まっていないと出来ませんから、現行のマクロでは、別ものになります。

今回のマクロのポイントの一つで、人によって、「"Scripting.Dictionary"」というものがあります。この外部オブジェクトを多用する人、そうでない人がいますが、私は、後者になります。本来は、「一意を抽出する(ユニーク)アルゴリズム」で対応できますが、モジュール全体のコードが膨らんでしまいますので、代わりに使いました。

>sheet1のデータベースからある一定条件の項目だけを抜き出し、

というマクロは、また別に存在すると言って間違いありません。経験的に、データが、数万行を越えるようなものは、このようなお茶を濁すようなものでは不十分かもしれません。

直感的に、今回の方法を選びました。もし、今回のマクロが趣旨が違うということならば、再度、ご趣旨に沿ったものを再考してもよいのですが、しばらく時間が必要です。

それから、コードの疑問点にはお応えしますが、あまり難しい話はナシにしてください。時々、「VBAを勉強していますが、『◯◯の概念』を教えて下さい」という人がいます。概念なんてあるとは思えないし、VBAは、仲の悪い2つのチームが、お互いが主張しながら、作り上げたVB6もどきの言語だと思っています。

私のVBAのモットーは「とりあえずエラーを出さない、結果が得られれば、それで良しということにする」ということです。そうしないと、いくらやってもキリがないし、前に進めないのです。

この回答へのお礼

WindFaller様
丁寧な解説とコードの全容をご教授していただきありがとうございます。
頂いたコードで一度実行しつつ、マニュアル本とにらめっこしながらコードの意味を理解してみようと思います。

お礼日時：2015/07/16 14:13

No.2 回答者： WindFaller 回答日時： 2015/07/16 10:53

zaki0124様

コメントは、次にお書きします。
-------------
'標準モジュールを使います。
'//
Sub DataAnalysis()
'No. 9022930-1
　Dim ws1 As Worksheet
　Dim ws2 As Worksheet
　Dim Ar() As Variant
　Dim i As Long, j As Long
　Dim w As Long, n As Long
　Dim k As Long, m As Long
　Dim Rng As Range
　Dim Params As Variant '数式のための引数
　Dim buf As String
　Dim a As String, b As String
　Dim TopCell As Range
　Dim Dic As Object
　
　Set Dic = CreateObject("Scripting.Dictionary")
　Set ws1 = Worksheets("Sheet1")
　Set ws2 = Worksheets("Sheet2")
　
　'別のシートの表を書き出す位置
　Set TopCell = ws2.Range("A1")
　With TopCell.CurrentRegion
　　If WorksheetFunction.CountA(.Cells) > 1 Then
　　　If MsgBox(ws2.Name & "の出力データを消します。よろしいですか？", vbOKCancel) = vbCancel Then Exit Sub
　　　.ClearContents
　　End If
　End With
　With ws1
　　w = .Cells(Rows.Count, 2).End(xlUp).Row
　　n = .Cells(2, Columns.Count).End(xlToLeft).Column
　　For j = 2 To n
　　　For i = 2 To w
　　　　If Not Dic.Exists(.Cells(i, j).Value) Then
　　　　　Dic.Add .Cells(i, j).Value, i
　　　　End If
　　　Next i
　　　ReDim Preserve Ar(j - 2)
　　　Ar(j - 2) = Dic.keys
　　　Dic.RemoveAll
　　Next j
　　Set Rng = .Range("B2:B" & w) '計算基準にする
　End With
　
　With TopCell
　　.Value = "品名"
　　k = UBound(Ar(0)) '横のカウント
　　.Offset(, 1).Resize(, k + 1).Value = Ar(0)
　　.Cells(1, k + 3).Value = "合　計"
　　m = UBound(Ar(3)) '縦のカウント
　　.Cells(2, k + 3).Resize(m + 1).FormulaLocal = "=SUM(RC[-" & k + 1 & "]:RC[-1])"
　　.Offset(1).Resize(m + 1).Value = Application.Transpose(Ar(3))
　　
　　.Cells(1, k + 6).Value = "人"
　　a = .Cells(1, k + 6).Offset(1).Address
　　.Cells(1, k + 7).Value = "期間"
　　b = .Cells(1, k + 7).Offset(1).Address
　　
　　Params = Array(.Cells(1, 2).Address(1, 0), b, a, .Cells(2, 1).Address(0, 1))
　　
　　For i = 0 To UBound(Params)
　　　buf = buf & "," & Rng.Offset(, i).Address(1, 1, , 1) & "," & Params(i)
　　Next
　　.Cells(2, 2).Resize(m + 1, k + 1).FormulaLocal = "=COUNTIFS(" & Mid(buf, 2) & ")"
　　.Cells(m + 3, 1).Value = "合 計"
　　.Cells(m + 3, 2).Resize(, k + 2).FormulaLocal = "=SUM(R[-1]C:R[-" & m + 1 & "]C)"
　End With
　MsgBox "サンプル抽出します。", vbInformation
　ws2.Range(a).Value = Ar(2)(0)
　ws2.Range(b).Value = ">" & Ar(1)(0)
End Sub

Sub SortData()
'No. 9022930-2
Dim Rng As Range
Dim r As Range
Dim r1 As Range
Dim r2 As Range
With ActiveSheet
　If .Range("A1") = "品名" Then
　 Set Rng = .Range("A1").CurrentRegion
　Else
　　MsgBox "データの先頭がA1ではありませんので、" & _
　　 "SortDataマクロの2行目と3行目のA1という文字を書き換えてください", vbExclamation
　End If
End With
　If MsgBox("並べ替えをします。", vbOKCancel) = vbCancel Then Exit Sub
　'縦の並べ替え
　With Rng
　 Set r = .Offset(0, 1).Resize(.Rows.Count, .Columns.Count - 2)
　 Set r1 = r.Rows(.Rows.Count) 'データの最後の行
　End With
　With ActiveSheet
　.Sort.SortFields.Clear
　.Sort.SortFields.Add Key:=r1, _
　 SortOn:=xlSortOnValues, _
　 Order:=xlDescending
　 With .Sort
　 .SetRange r
　 .Header = xlYes
　 .Orientation = xlSortRows '←xlLeftToRight
　 .Apply
　End With
　End With
　'横の並べ替え
　With Rng
　 Set r = .Resize(.Rows.Count - 1, .Columns.Count)
　 Set r2 = r.Columns(.Columns.Count) 'データの最後の列
　End With
　With ActiveSheet
　.Sort.SortFields.Clear
　.Sort.SortFields.Add Key:=r2, _
　 SortOn:=xlSortOnValues, _
　 Order:=xlDescending
　 With .Sort
　 .SetRange r
　 .Header = xlYes
　 .Orientation = xlSortColumns　'←xlTopToBottom
　 .Apply
　End With
　End With
End Sub
'///

No.1 回答者： WindFaller 回答日時： 2015/07/15 18:57

たぶん、きちんとした表を作っているのですから、マクロでなく、ピボットテーブルにしたらいかがでしょうか？一応、マクロも用意したものの、「VBA初心者です」から、「解説をしてください」と言われても、それはマクロとはまったく別の作業になり、マクロを書くと同じぐらいに大変なことです。

内容にもよりますが、私には、苦痛そのものなのです。設定ぐらいでしたら、お教えしますが、それ以上はできかねます。

ピボットテーブルでするようなことを、マクロで再現するのは、短いコードですが、COUNTIFS を使う数式を作るためのコードは、意外にも複雑になってしまい、「初心者」という方を対象とした場合、（少なくとも私のコードでは)、ほとんど参考にもなりません。もし、それでもご興味がありましたら、マクロの全文を公開しますが、他の方の回答を待ってもよいかと思います。

画像にもありますが、このような数式が、計算部分に埋まります。
=COUNTIFS(Sheet1!$B$2:$B$13,B$1,Sheet1!$C$2:$C$13,$I$2,Sheet1!$D$2:$D$13,$H$2,Sheet1!$E$2:$E$13,$A2)

この回答へのお礼

WindFallerさんへ
回答ありがとうございます。
ピポットテーブルでは作成できるのですが、ＶＢＡで実行したかったので（将来的に色々なことをＶＢＡで作成できるようになりたいための勉強も兼ねて）もしよろしければ全文公開していただけると嬉しいです。
参考書とにらめっこしながら、全文を解読すればレベルアップになりそうですしね。

お礼日時：2015/07/15 20:13