Sheet1をフィルターで「りんご」を抽出し、Sheet2へ地域を貼り付ける下記マクロを変更して S

Sheet1をフィルターで「りんご」を抽出し、Sheet2へ地域を貼り付ける下記マクロを変更して
Sheet2のB列で青森が２行あれば、C列へ「2」、B列で長野が1行あればC列へ「1」と
行をカウントした数値を入れたいのですができません。教えてください。

Sub test1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastCell As Long
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
LastCell = ws1.Cells(Rows.Count, 2).End(xlUp).Row
With ws1.Range("B4")
.AutoFilter 1, "りんご"
.Offset(1, 3).Resize(LastCell - 4).Copy ws2.Range("B3")
　　　　.AutoFilter
End With
End Sub

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

• test1実行後、別の下記コードで長野の数はカウントできるのですが、長野など他の地域がカウントできません。
  
  Sub test2()
  Dim Count As Long
  Range("B2").AutoFilter 1, Range("B3")
  Count = WorksheetFunction.Subtotal(3, Range("B3").CurrentRegion.Columns(1))
  Range("C3").Value = Count - 1
  ActiveSheet.AutoFilterMode = False
  End Sub

    補足日時：2022/12/11 03:30

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2022/12/11 17:37

実験用コードです（添削）

Sub test1()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim LastCell As Long
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
LastCell = ws1.Cells(Rows.Count, 2).End(xlUp).Row
ws2.Cells(1, 1) = "りんご"
ws2.Cells(2, 2) = "地域"
ws2.Cells(2, 3) = "カウント"
ws2.Range("B3", ws2.Cells(Rows.Count, "B").End(xlUp).Offset(1)).ClearContents
With ws1.Range("B4")
.AutoFilter 1, "りんご"
.Offset(1, 3).Resize(LastCell - 4).Copy ws2.Range("B3")
.AutoFilter
End With
End Sub

test2代替えScripting.Dictionary
Sub test2()
'Worksheets(2)をデータ加工
Dim dic As Object, vKey
Set dic = CreateObject("Scripting.Dictionary")
Dim ws2 As Worksheet: Set ws2 = Worksheets(2)
Dim rng As Range, r As Range
Set rng = ws2.Range("B3", ws2.Cells(Rows.Count, "B").End(xlUp))
'一意データを作成+カウント
For Each r In rng
If Not dic.Exists(r.Text) Then
dic.Add r.Text, 1
Else
dic.Item(r.Text) = dic.Item(r.Text) + 1
End If
Next
Dim n As Long
n = 3
'出力先をClearContents
rng.Resize(, 2).ClearContents
For Each vKey In dic.Keys
ws2.Cells(n, 2) = vKey
ws2.Cells(n, 3) = dic.Item(vKey)
n = n + 1
Next
Set dic = Nothing
End Sub

やっぱり加工したものを出力したいですね
AutoFilter第2基準キーを使って
Sub test3()
Dim dic As Object, vKey As Object
Set dic = CreateObject("Scripting.Dictionary")
Dim ws1 As Worksheet, ws2 As Worksheet
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Dim rng As Range, r As Range
Set rng = ws1.Range("B5", ws1.Cells(Rows.Count, "B").End(xlUp))
'一意データを作成（地域）
For Each r In rng.Offset(, 3)
If Not dic.Exists(r.Text) Then
dic.Add r.Text, 1
End If
Next
Dim arrKey, Ky, ary()
Dim n As Long, cnt As Long
arrKey = dic.Keys
ReDim ary(UBound(arrKey), 1)
Application.ScreenUpdating = False
With ws1
If .AutoFilterMode Then
.AutoFilterMode = False
End If
With .Range("B4")
.AutoFilter 1, "りんご" '第1キーワードでフィルタ（品名
For Each Ky In arrKey
.AutoFilter 4, Ky, xlFilterValues '第2キーワードでフィルタ（地域
cnt = Application _
.Subtotal(3, .Range("B5").CurrentRegion.Columns(1)) - 1
If cnt > 0 Then
'対象地域があった場合に各値を配列に代入
ary(n, 0) = Ky
ary(n, 1) = cnt
n = n + 1
End If
Next
End With
.AutoFilterMode = False
End With
'取得処理終了後　対象シート範囲に出力
ws2.Cells(1, 1) = "りんご"
ws2.Cells(2, 2) = "地域"
ws2.Cells(2, 3) = "カウント"
ws2.Cells(3, 2) _
.Resize(UBound(ary, 1) + 1, UBound(ary, 2) + 1) = ary
Application.ScreenUpdating = True
End Sub

この回答へのお礼

test2代替えScripting.Dictionaryの
If Not dic.Exists(r.Text) Then
dic.Add r.Text, 1
とn = n + 1
この2つがやっと理解できました。
またDictionaryオブジェクトには色々な決め事があり少しづつ勉強して利用できるようにしたいです。
ありがとうどざいました。

お礼日時：2022/12/11 20:37

No.1 回答者： Qchan1962 回答日時： 2022/12/11 16:51

こんばんは

＞test1実行後、別の下記コードで長野の数はカウントできるのですが、長野など他の地域がカウントできません。

これは長野に対しての基準キーワードが無い為です
同じ範囲に改めてRange("B2").AutoFilter 1, Range("B4")とすれば取得できると思いますが・・ループなどでそのまま変えていくと長野がまた実行されてしまいますね
test1についてはリストなどから"りんご"を設定すれば良いかも知れませんが
test2は結果に応じてフィルタ基準キーワードを作る必要があります
test1もすべての品名を一度に処理する場合は必要

一意の基準キーワードを作成するには　UNIQUE 関数+FILTER関数や
CreateObject("Scripting.Dictionary")で作る方法が好ましいと思います
DictionaryはUniqueデータ作成時にitemを作成する事が出来るので出現回数をカウントする事も出来ます

しかし、すべての品名を出力したい場合、 test2はWorksheets(2)に対しての加工なので課題が残りそうですね　
品名ごとにシートをずらせば良さそうですがどうかな・・

Sub test1()とSub test2()を同じAutoFilterで行う事も出来ると思いますが
Copyを使うのをあきらめる必要があるかも知れませんね