Sheet1の出荷日と品名が並んだ表からSheet2の品名別出荷日別の個数一覧表を作っています。 オ

Sheet1の出荷日と品名が並んだ表からSheet2の品名別出荷日別の個数一覧表を作っています。
オートフィルターで品名と日付を条件に個数をカウントし転記していますがマクロで自動化できないかと試行錯誤していますができません。
Sheet2のセルC3だけカウントする下記マクロを作りましたが、条件が多く先に進めません。
①月間の発生日付が決まっていない
（ＭＡＸ月間31日）
②取り扱い品名の中、発生する品名が決まっていない
（取り扱い品名りんご、ぶどう、いちご、ばなな、みかん、めろん）
変数を使ってカウントするのだろうとはおもうのですがどこをどう変更したら良いか教えてください。

Sub test1()

Dim Count As Long
Range("B2").AutoFilter 1, "2022/10/14"
Range("B2").AutoFilter 2, "りんご"

Count = WorksheetFunction.Subtotal(3, Range("B2").CurrentRegion.Columns(1))
Worksheets(2).Activate
Range("C3").Value = Count - 1

End Sub

No.3 ベストアンサー 回答者： Qchan1962 回答日時： 2022/12/02 14:55

こんにちは

Excelの機能、関数を使用いた方が良いように思いますが
他のVBAと組み合わせたりするのかも知れませんね

＞オートフィルターで品名と日付を条件に
フィルタで出来ますが、関数の方が簡単ではないでしょうか
（＃２様の関数式をセルにVBAで書き込むならもっと簡単かも）

手順（一例です）
フィルタ操作でも同じですが　品名と日付のデータをそれぞれユニークデータを作成します
それをキーにフィルタや総当たり又は関数などでカウントします
（ユニークデータは総当たりで日付セルの値はシリアル値が前提です）
日付データをソートすると順番になりますが割愛
サンプル１
Sub test1()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim arrItem1 As Variant, arrItem2 As Variant
Dim arrAns() As Variant
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
Dim productRng As Range, dateRng As Range

'データ取得
With sht1
Set productRng = .Range("B3", .Cells(Rows.Count, "B").End(xlUp))
Set dateRng = .Range("D3", .Cells(Rows.Count, "D").End(xlUp))
'ユニークデータに加工
arrItem1 = Application.Unique(productRng)
arrItem2 = Application.Unique(dateRng)
End With
'出力サイズ（配列に一時保存）
ReDim arrAns(UBound(arrItem2), UBound(arrItem1))
'メインプロセス
Dim i As Long, j As Long
For i = 1 To UBound(arrItem2)
For j = 1 To UBound(arrItem1)
If IsEmpty(arrAns(i, 0)) Then arrAns(i, 0) = arrItem2(i, 1)
arrAns(i, j) = Application.CountIfs(productRng, arrItem1(j, 1), dateRng, arrItem2(i, 1))
Next
Next
'出力（書式を設定）
With sht2.Range("B2")
.Resize(UBound(arrAns, 1) + 1, UBound(arrAns, 2) + 1) = arrAns
.Offset(, 1).Resize(, UBound(arrItem1)) = Application.Transpose(arrItem1)
.Offset(, 1).Resize(, UBound(arrItem1)).NumberFormatLocal _
= sht1.Range("B3").NumberFormatLocal
End With
End Sub

総当たりの場合　サンプル２
'メインプロセス
Dim arrData
Dim i As Long, j As Long, n As Long
arrData = sht1.Range("B3", sht1.Cells(Rows.Count, "D").End(xlUp))
For i = 1 To UBound(arrItem2)
For j = 1 To UBound(arrItem1)
For n = 1 To UBound(arrData)
'Dataの1列目、３列目
If arrItem1(j, 1) = arrData(n, 1) And arrItem2(i, 1) = arrData(n, 3) Then
If IsEmpty(arrAns(i, 0)) Then arrAns(i, 0) = arrItem2(i, 1)
arrAns(i, j) = arrAns(i, j) + 1
End If
Next
Next
Next
他は多分同じ？

フィルタの場合は少し難しいかな　サンプル3
Sub test2()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim arrItem1, arrItem2
Dim arrAns()
Dim i As Long, j As Long
Set sht1 = Worksheets("Sheet1")
Set sht2 = Worksheets("Sheet2")
'データ取得
With sht1
arrItem1 = Application.Unique(.Range("B3", .Cells(Rows.Count, "B").End(xlUp)))
arrItem2 = Application.Unique(.Range("D3", .Cells(Rows.Count, "D").End(xlUp)))
End With
'出力サイズ
ReDim arrAns(UBound(arrItem2), UBound(arrItem1))
Application.ScreenUpdating = False
sht1.Activate
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.Range("B2").AutoFilter
For i = 1 To UBound(arrItem2)
For j = 1 To UBound(arrItem1)
'----フィルタ
With sht1.Range("B2")
.AutoFilter 1, Format(arrItem1(j, 1), sht1.Range("B3").NumberFormatLocal)
.AutoFilter 3, arrItem2(i, 1)
End With
If IsEmpty(arrAns(i, 0)) Then arrAns(i, 0) = arrItem2(i, 1)
arrAns(i, j) = WorksheetFunction.Subtotal(3, sht1.Range("B2").CurrentRegion.Columns(1)) - 1
'----までフィルタ
Next
Next
'出力
With sht2.Range("B2")
.Resize(UBound(arrAns, 1) + 1, UBound(arrAns, 2) + 1) = arrAns
.Offset(, 1).Resize(, UBound(arrItem1)) = Application.Transpose(arrItem1)
.Offset(, 1).Resize(, UBound(arrItem1)).NumberFormatLocal _
= sht1.Range("B3").NumberFormatLocal
End With
ActiveSheet.Range("B2").AutoFilter
Application.ScreenUpdating = True
End Sub

私はピボットテーブルに一票ですがVBAをあきらめますか

この回答へのお礼

ありがとうございます。自分でも質問の後、シート2の表で縦軸と横軸を作るところまではできました。ただ縦横の値でフィルターをかけると表示された値が求められず悩んでいます。一旦この質問はクローズして別の質問をさせていただきます。

お礼日時：2022/12/02 15:53

No.2 回答者： fujillin 回答日時： 2022/12/02 13:36

こんにちは

VBAのご質問ですが、手っ取り早くやるなら・・
（以下、スピル機能のある環境を想定しています）

Sheet2のB3セルに
=UNIQUE(FILTER(Sheet1!D4:D99,Sheet1!D4:D99<>"",""))
C2セルに
=TRANSPOSE(UNIQUE(FILTER(Sheet1!B4:B99,Sheet1!B4:B99<>"","")))
C3セルに
=COUNTIFS(Sheet1!B4:B99,C2#,Sheet1!D4:D99,B3#)
を入力しておくことで、ほぼご質問の内容を実現することが可能です。

ただし、
・日付は元の表中の出現日しか表示されない（必ずしも連続日にはならない）
・Countifでカウントしているので、該当がない部分は0表示になる
等の点が異なります。
日付に関しては、対象範囲のMINとMAXを利用して、その間を1日ずつ表示すれば連続する日を表示することは可能と思いますけれど。


VBAで行う場合でも、ご提示の内容ではオートフィルター後にSUBTOTAL関数でカウントしようとなさっていますが、シート関数を利用するのであれば、COUNTIFSを利用することでフィルター操作をしなくても済むと思われます。
https://learn.microsoft.com/ja-jp/office/vba/api …
あるいは、普通に行をループして地道に数えるという方法も考えられますね。

No.1 回答者： 銀鱗 回答日時： 2022/12/02 00:16

(´・ω・`)「ピボットテーブル」で「出荷先」を数えれば良いような気がするんですけど、

それではダメなんですか？