| |
▼ひかる さん：
>▼kanabun さん：
>失礼しました。大人/小人と男/女を入れ替えればよかっただけですね。
いいえ、（集計先シートのレイアウトは 同じですが、）
元表が 日付列と 利用者列と 性別列 の合計 3列の種別になるんでしょ？
この元表を使いまわしたいのでしょ？
Sub Try3() '集計先のシートをアクティブにして実行
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim dic As Object
Dim r As Range, c As Range
Dim tbl
Dim i As Long
Dim strRoom As String '◆追加
Dim strSecond As String '◆追加
'---- 書き出し先のテーブル情報をDictionaryに格納 -----
Set dic = CreateObject("Scripting.Dictionary")
Set WS1 = Worksheets("◆Sheet1")
Set WS2 = ActiveSheet
With WS2
Set r = .Range("A1").CurrentRegion '書きこみ先表範囲
r.Select
MsgBox "この範囲が表全体"
End With
Set r = Intersect(r, r.Offset(1, 2)) 'そのうち、正味データ部 ◆変更
r.Select
MsgBox "この範囲が正味データ範囲"
r.ClearContents '行列見出しを除く正味データ部をクリア
tbl = r.Value 'クリア後の範囲を配列に格納
'行列見出し位置を辞書に格納
For Each c In r.Resize(, 1).Offset(, -1) 'A＋B列見出し項目（室＋大小）
i = i + 1
If Len(c(1, 0).Text) Then strRoom = c(1, 0).Text
dic(strRoom & c.Text) = i
Next
i = 0
For Each c In r.Resize(1).Offset(-1) '1行目見出し項目（月）
i = i + 1
dic(c.Text) = i
Next
strSecond = WS2.[B2].Value '第2 項目（見出し）のサンプル
'---- 元表のA列×1行目の見出しに対応する 書きこみ先の _
配列tblの 行列番号を Dictionaryから得る -----
Dim rr As Range
Dim MonData, RoomData, dat, ss As String
Dim SecondData 'B列またはC列格納用変数
Dim j As Long, n As Long, m As Long, x As Long
With WS1
.Activate '◆デバッグ用追加
Set rr = .Range("A1").CurrentRegion '.Resize(, 5)
rr.Select '←↓◆◆デバッグ用追加
If MsgBox("この範囲が元データ範囲 " & _
rr.Address(0, 0), vbOKCancel) = vbCancel Then Exit Sub
End With
Set rr = Intersect(rr, rr.Offset(1, 3)) '◆列方向 D列から 「室」見出し
rr.Select '←↓◆◆デバッグ用追加
MsgBox "この範囲が正味数値データ範囲 " & rr.Address(0, 0)
MonData = rr.Offset(, -3).Resize(, 1).Value
Set c = rr.Offset(, -2).Resize(, 2)
Set c = c.Find(strSecond, , xlValues, xlWhole)
If c Is Nothing Then
MsgBox "第2項目の列取得に失敗しました" & vbCr _
& " 元データシートの B,C列に <" & strSecond & _
"> が見つかりませんでした"
Exit Sub
End If
Select Case c.Column 'どの列（B列／C列）で集計するのか 調べる
Case 2: x = -2
Case 3: x = -1
End Select
SecondData = rr.Offset(, x).Resize(, 1).Value
RoomData = rr.Resize(1).Offset(-1).Value
For i = 1 To UBound(MonData, 1) '日付のレコード順に
dat = MonData(i, 1)
If IsDate(dat) Then
ss = Month(dat) & "月"
If dic.Exists(ss) Then
m = dic(ss) '何列目か
For j = 1 To UBound(RoomData, 2)
ss = RoomData(1, j) & SecondData(i, 1)
If dic.Exists(ss) Then
n = dic(ss) '何行目か
'------tblのn行,m列目の要素に 数量を累加 -----
tbl(n, m) = tbl(n, m) + rr(i, j).Value
End If
Next
End If
End If
Next
'---- 配列に集計した結果を表に書き出す ------
r.Value = tbl
WS2.Activate
End Sub
>あと1点ご質問させていただいた日付の点のほうもよろしくお願いします。
すみません。ちょっと時間がなくなったので、
どなたか 考えてあげてください。
（出張のため、しばらくレスできません）
|
|
kanabun
- 09/1/20(火) 22:50 -
