シートごとに 個数と集計

いつもお世話になっております

シート名　1　2　3　があります。
シートごとに　個数と集計をしたいのです。
シートごとです。
わかる方教えてくれませんでしょぅか　


Sub erfssa()
Dim Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
Dim val

val = Range("B2").CurrentRegion.Offset(1).Value
Dim wS As Worksheet


aay = Array("1", "2", "3")
For i = LBound(aay) To UBound(aay)
For Each r In Worksheets(aay(i)).Range("B3", Cells(Rows.Count, 2).End(xlUp))

If Not Dic.Exists(r.Value) Then
Dic.Add r.Value, Array(1, WorksheetFunction.Sum(r.Offset(, 1).Value))
Else
v = Dic(r.Value)
v(0) = v(0) + 1
v(1) = v(1) + WorksheetFunction.Sum(r.Offset(, 1).Value)
Dic(r.Value) = v
End If
Next



Dim rr As Range

Set rr = Range("E2")

For Each Key In Dic.Keys
rr.Value = Key
rr.Offset(, 1).Resize(, 2) = Dic(Key)

Set rr = rr.Offset(1)
Next

Next










End Sub

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

• 画像添付できませんでした。
  シート名1　同様シート名2　3　に
  も
  
  支社 売上 　　　青森支社 3 10500
  青森支社 1500 秋田支社 3 12000
  秋田支社 2000 福島支社 3 13500
  福島支社 2500 岩手支社 2 8000
  岩手支社 3000
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500
  秋田支社 6000
  福島支社 6500

    補足日時：2021/10/25 22:07

• シート2
  支社 売上 　　　青森支社 5 19500
  青森支社 1500 秋田支社 4 16000
  秋田支社 2000 福島支社 4 18000
  福島支社 2500 岩手支社 3 13000
  岩手支社 3000
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500
  秋田支社 6000
  福島支社 6500
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500

    補足日時：2021/10/25 22:09

• シート2
  支社 売上 　　　　青森支社 5 19500
  青森支社 1500 秋田支社 4 16000
  秋田支社 2000 福島支社 4 18000
  福島支社 2500 岩手支社 3 13000
  岩手支社 3000
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500
  秋田支社 6000
  福島支社 6500
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500

    補足日時：2021/10/25 22:10

• シート3
  支社 売上 　　　青森支社 5 19500
  青森支社 1500 秋田支社 4 16000
  秋田支社 2000 福島支社 4 18000
  福島支社 2500 岩手支社 3 13000
  岩手支社 3000
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500
  秋田支社 6000
  福島支社 6500
  青森支社 3500
  秋田支社 4000
  福島支社 4500
  岩手支社 5000
  青森支社 5500

    補足日時：2021/10/25 22:11

• 

  すいません、シート2だぶりました。

    補足日時：2021/10/25 22:12

No.2 ベストアンサー 回答者： めぐみん_ 回答日時： 2021/10/25 23:30

データがどこの列にあるかで悩みました。

Sub megu()

Dim Dic As Object
Dim r As Range, rr As Range
Dim aay, ar_ws, key, v

Set Dic = CreateObject("Scripting.Dictionary")

aay = Array("1", "2", "3")
For Each ar_ws In aay

With Worksheets(ar_ws)

Set rr = .Range("E2")

For Each r In .Range("B3", .Cells(Rows.Count, 2).End(xlUp))
If Not Dic.Exists(r.Value) Then
Dic.Add r.Value, Array(1, r.Offset(, 1).Value)
Else
v = Dic(r.Value)
v(0) = v(0) + 1
v(1) = v(1) + r.Offset(, 1).Value
Dic(r.Value) = v
End If
Next


For Each key In Dic.Keys
rr.Value = key
rr.Offset(, 1).Resize(, 2) = Dic(key)
Set rr = rr.Offset(1)
Next

Dic.RemoveAll

End With

Next

Set Dic = Nothing
Set rr = Nothing

End Sub

この回答へのお礼

いつもお世話になっております
わかりにくい
質問で申し訳ございませんでした。
うまくいきました。
とても嬉しいです。

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

お礼日時：2021/10/26 08:18

No.1 回答者： fujillin 回答日時： 2021/10/25 22:50

こんばんは

＞シートごとに　個数と集計をしたいのです
何の個数を、どのように集計したいのかがサッパリわかりません。
仮に計算できたとしても、それをどうしたいのかもわかりません。
（なさりたいことをキチンと伝えないと、回答のしようがありません。）

全くの当てずっぽうで、勝手に以下と推測。
（違っている場合は、以下はすべて無視してください）
・対象範囲は、各シートのB列3行目から最終行までと想定。
・「集計」とは、対象範囲の中の、数値の合計を求めるものと想定。
・「個数」とは、対象範囲の中の、数値の個数を求めるものと想定。
・結果は、とりあえずイミディエイトウインドウに出力します。

以下、ご参考にでもなれば。
（エラー処理等は、一切行っていません）

Sub Sample()
Dim ws As Worksheet, rng As Range
Dim aay, rw As Long, i As Long
aay = Array("1", "2", "3")

For i = LBound(aay) To UBound(aay)
Set ws = Worksheets(aay(i))
rw = Application.Max(ws.Cells(Rows.Count, 2).End(xlUp).Row, 3)
Set rng = Range(ws.Cells(3, 2), ws.Cells(rw, 2))

Debug.Print "シート名:" & ws.Name
Debug.Print "個数：" & WorksheetFunction.Count(rng)
Debug.Print "合計：" & WorksheetFunction.Sum(rng) & vbCrLf
Next i
End Sub

この回答へのお礼

ありがとうございます
これをシートごとセルに
表示させるようにやってみます。

お礼日時：2021/10/25 23:01