Sheet「状況」から、分類の年齢別カウント数をSheet「D表」へ転記する下記マクロを作っています

Sheet「状況」から、分類の年齢別カウント数をSheet「D表」へ転記する下記マクロを作っています。しかしセルごとにカウント数を転記すると44個のセルがあり、同じようなマクロが必要になるため、D表の行と列を参照してループできるようなマクロを勉強したいのですが教えてください。

Sub D表19()
Worksheets("状況").Activate
Call Z_AutoFilterOff
Dim Count As Long
With Range("B4")
　　　　.AutoFilter 2, "A" '抽出分類
　　　　.AutoFilter 4,Criteria1:="<=19" '抽出年齢
End With
Count = WorksheetFunction.Subtotal(3, Range("B4").CurrentRegion.Columns(1))
Worksheets("D表").Activate
Range("C5").Value = Count - 1
End Sub

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

• お示しいただいたコードを検証させていただき気がついたのですがD表の項目A、B、C、Dが条件シートの分類1と分類2列の何れかに入っていました。オートフィルター以外の方法をとった方が良いでしょうか。教えてください。

    補足日時：2022/12/18 01:50

No.5 ベストアンサー 回答者： Qchan1962 回答日時： 2022/12/18 05:27

>Case "不明": key = ""で空白セルがカウントされないのですがどのように変更したら良いでしょうか。

該当部分

If buf(0) <> "不明" Then
.AutoFilter 4, Criteria1:=">=" & buf(0), Operator:=xlAnd, Criteria2:="<=" & key
Else
.AutoFilter 4, Criteria1:="=" & buf(0)
End If
Count = WorksheetFunction.Subtotal(3, Worksheets("状況").Range("B4").CurrentRegion.Columns(1))
Worksheets("D表").Cells(r.Row, c.Column).Value = Count - 1
Next

＞分類1と分類2列の何れかに入っていました。
ならば片方は空白セルと言う事？
であれば、配置も変わらないようですしデータ数も対してないので
処理の初めに対象列に纏めて処理後戻すなんて力業でやっちゃうかな

意図があって分類Ⅰと分類Ⅱとして分けているのでしょうから　
考え方として分類Ⅰと分類Ⅱを分けて算出して合算するようにした方が
分類Ⅰはいくつ分類Ⅱ～と出しやすいのでは無いでしょうか・・

＞オートフィルター以外の方法をとった方が良いでしょうか。
確かに・・そうかも知れないですけれど

＞D表の行と列を参照してループできるようなマクロを勉強したいのですが教えてください。

このことを考えたので　値の取得方法やFor Eachを使ってCells(r.Row, c.Column)の関係を見てもらいました
（処理の合理性は考慮していません出来るだけ質問にあるものを使いましたのであしからず）

この回答へのお礼

ありがとうございます。勉強になりました。
やっと理解できました！

お礼日時：2022/12/19 17:15

No.7 回答者： Qchan1962 回答日時： 2022/12/18 16:00

＃２，＃５です

＞処理の初めに対象列に纏めて処理後戻すなんて力業でやっちゃうかな
AutoFilterに拘って、出来るだけ定数を使わないようにしてみました

何のこっちゃ　となると思いますのでコードです

Sub Example01()
Dim WsD As Worksheet
Dim wsStatus As Worksheet
'シート設定
Set WsD = Worksheets("D表")
Set wsStatus = Worksheets("状況")
'上限定数
Const upper_limit As Long = 120

Dim Count As Long
Dim c As Range, r As Range
Dim buf As Variant, key As Variant
Dim ary As Variant, i As Integer

Dim extracting_classification As Range
Dim extracting_age As Range
Dim Rng As Range
'範囲設定
Set extracting_classification = WsD.Range("C4:F4") '抽出分類
Set extracting_age = WsD.Range("B5:B15") '抽出年齢
Set Rng = wsStatus.Range("C5:C15")
'AutoFilterの為表組み操作
ary = Rng.Resize(, 2)
For Each r In Rng
If r.Value = "" Then r.Value = r.Offset(, 1).Value
Next

wsStatus.Activate
'Call Z_AutoFilterOff
For Each c In extracting_classification '抽出分類ループ
With wsStatus.Range("B4")
.AutoFilter 2, c.Text
For Each r In extracting_age '抽出年齢ループ
buf = Split(r.Text, "~")
Select Case buf(0)
Case extracting_age(1): key = upper_limit
Case extracting_age(extracting_age.Count): key = ""
Case Else: key = buf(1)
End Select
If r.Row = extracting_age(1).Row Then buf(0) = 0
If r <> extracting_age(extracting_age.Count) Then
.AutoFilter 4, Criteria1:=">=" & buf(0), _
Operator:=xlAnd, Criteria2:="<=" & key
Else
.AutoFilter 4, Criteria1:="=" & buf(0)
End If
Count = WorksheetFunction.Subtotal(3, .CurrentRegion.Columns(1))
WsD.Cells(r.Row, c.Column).Value = Count - 1 '出力
Next
End With
Next
'Call Z_AutoFilterOff
'表組み戻す
Rng.ClearContents
Rng.Value = ary
End Sub

この回答へのお礼

ありがとうございます。勉強してみます。

お礼日時：2022/12/19 17:13

No.6 回答者： tatsumaru77 回答日時： 2022/12/18 10:32

No4です。

レイアウトは提示された状態から変わらない前提です。
オートフィルターは使用していません。
不明点があれば、補足してください。

Option Explicit
Public Sub 年齢別カウント()
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim maxrow1 As Long
Dim row1 As Long
Dim row2 As Long
Dim col2 As Long
Dim rgs As String
Dim rgs1 As String
Dim rgs2 As String
Dim idx As Long
Dim bun As String
Set sh1 = Worksheets("状況")
Set sh2 = Worksheets("D表")
sh2.Range("C5:G16").ClearContents
maxrow1 = sh1.Cells(Rows.Count, "B").End(xlUp).Row
For row1 = 5 To maxrow1
bun = sh1.Cells(row1, "C").Value
idx = GetBunrui(bun)
If idx < 0 Then
MsgBox ("分類1不正")
sh1.Select
sh1.Cells(row1, "C").Select
Exit Sub
End If
col2 = idx + 3
idx = GetAge(sh1.Cells(row1, "E").Value)
row2 = idx + 5
sh2.Cells(row2, col2).Value = sh2.Cells(row2, col2).Value + 1
Next
For col2 = 3 To 6
rgs1 = sh2.Cells(5, col2).Address(False, False)
rgs2 = sh2.Cells(15, col2).Address(False, False)
rgs = rgs1 & ":" & rgs2
sh2.Cells(16, col2).Formula = "=sum(" & rgs & ")"
Next
For row2 = 5 To 16
rgs = "A" & row2 & ":F" & row2
sh2.Cells(row2, "G").Formula = "=sum(" & rgs & ")"
Next
MsgBox ("完了")
End Sub
Private Function GetBunrui(ByVal bun As String) As Long
Dim buns As Variant
Dim i As Long
buns = Array("A", "B", "C", "D")
For i = 0 To UBound(buns)
If bun = buns(i) Then
GetBunrui = i
Exit Function
End If
Next
GetBunrui = -1
End Function

Private Function GetAge(ByVal vage As Variant) As Long
Dim vals As Variant
Dim i As Long
Dim age As Long
vals = Array(0, 20, 25, 30, 35, 40, 45, 50, 55, 60, 999)
GetAge = UBound(vals)
If IsNumeric(vage) = False Then Exit Function
age = Int(vage)
If age < vals(0) Or age >= vals(UBound(vals)) Then Exit Function
For i = 0 To UBound(vals) - 1
If age >= vals(i) And age < vals(i + 1) Then
GetAge = i
Exit Function
End If
Next
End Function

この回答へのお礼

ありがとうございます。勉強してみます。

お礼日時：2022/12/19 17:14

No.4 回答者： tatsumaru77 回答日時： 2022/12/16 11:50

No3です。

提示されたレイアウトが変わらない前提であれば、マクロの提供は簡単です。
レイアウトが変更されても自動的に対応する場合は、かなりやっかいになります

この回答へのお礼

ありがとうございます。レイアウトはかわりません。
どのように記述したら良いでしょうか。

お礼日時：2022/12/18 01:44

No.3 回答者： tatsumaru77 回答日時： 2022/12/15 17:53

>D表の行と列を参照してループできるようなマクロを勉強したいのですが教えてください。

D表の行と列が増減しても自動的に対応できるようなマクロを作りたいということでしょうか。
例１：行の増加
６０以上を
①60～64
②65～69
③70～
の年齢に変更する。

例２：列の増加
分類1をA,B,C,DからA,B,C,D,E,Fに変える。

上記の例１、例２のような変更をおこなっても、自動的に対応できるようなマクロを作りたいということでしょうか。

No.2 回答者： Qchan1962 回答日時： 2022/12/15 04:14

こんばんは

D表シートの値を参照するようにするには、表組みと例のコードを生かすと
少し分かり難いコードになるかと、例のコードを理解しているものとして
（説明、手法を言葉で書いても伝わりにくいと思うと共に完成で無いと思いますので）
サンプルを書きます検証してみてください　

D表の参照セルの値で変わるようになっていますが　値を文字などにした場合エラーが発生します
"不明" などの対応コードを参考に条件を増やしたり、
On Error Resume Next などエラー処理を加える必要があります
また、ループと出力セルの関係なども検証してください

試す時に間違いがあるといけないので記すと年齢の列の　~　は半角でコードを書いています( ~ は重要なエレメントになっています)

Sub Example()
Worksheets("状況").Activate
Call Z_AutoFilterOff
Dim Count As Long
Dim c As Range, r As Range
Dim buf, key
For Each c In Worksheets("D表").Range("C4:F4") '抽出分類ループ
With Worksheets("状況").Range("B4")
.AutoFilter 2, c.Text
For Each r In Worksheets("D表").Range("B5:B15") '抽出年齢ループ
buf = Split(r.Text, "~")
Select Case buf(0)
Case "不明": key = ""
Case 60: key = 120
Case Else: key = buf(1)
End Select
If key = 19 Then buf(0) = 0
.AutoFilter 4, Criteria1:=">=" & buf(0), Operator:=xlAnd, Criteria2:="<=" & key
Count = WorksheetFunction.Subtotal(3, Worksheets("状況").Range("B4").CurrentRegion.Columns(1))
Worksheets("D表").Cells(r.Row, c.Column).Value = Count - 1
Next
End With
Next
End Sub

この回答へのお礼

ありがとうございます。Case "不明": key = ""で空白セルがカウントされないのですがどのように変更したら良いでしょうか。

お礼日時：2022/12/18 01:42

No.1 回答者： rexfan 回答日時： 2022/12/14 19:20

１．For NextやDo　Loopを覚える。

２．配列処理を覚える。