| |
▼ひかる さん：
>以前のデータから、今度は、室の利用者が、大人か小人かの項目が増えた場合、どういったVBAコードで下の表が埋めれますか。お教えください。
>
>以前のデータに利用者がプラス
> A B C D E F
>-----------------------------------------------------------------------
>1 日付 利用者 会議室 研修室 和室 調理室
>2 4月15日 大人 560 800 1000 500
>3 4月19日 小人 1500 600 5200 1500
>4 5月21日 大人 800 2000 800 2100
>5 5月31日 小人 5000 480 2500 600
>6 6月13日 小人 4500 3600 4800 1600
>7 6月18日 大人 100 3600 8400 2650
>8 6月21日 大人 7000 600 8000 7900
というデータがあるとき、
集計先のA,B列見出しをまとめて「会議室大人」という見出しの【行】
の「4月」の【列】 に。。。と行列をまとめて
集計していけば、
4月 5月 6月 7月
会議室 大人 560 800 7100
会議室 小人 1500 5000 4500
研修室 大人 800 2000 4200
研修室 小人 600 480 3600
和室 大人 1000 800 16400
和室 小人 5200 2500 4800
調理室 大人 500 2100 10550
調理室 小人 1500 600 1600
Sub Try1()と同じ考えでできます。
シート名は 元表のあるシートが"◆Sheet1"
集計先が "◆Sheet2" として記述してますので、そちらの環境に合わせて
ください。
コードは デバッグ用に シートを選択したり、範囲をMsgBoxで確認したり
していますので、デバッグが終わったら、コメントアウト(コメント化)して
ください。
Sub Try2()
Dim dic As Object
Dim r As Range, c As Range
Dim tbl
Dim i As Long
Dim strRoom As String '◆追加
'---- 書き出し先のテーブル情報をDictionaryに格納 -----
Set dic = CreateObject("Scripting.Dictionary")
With Worksheets("◆Sheet2")
.Activate
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
'---- 元表のA列×1行目の見出しに対応する 書きこみ先の _
配列tblの 行列番号を Dictionaryから得る -----
Dim rr As Range
Dim MonData, RoomData, dat, ss As String, ACdata '「大人／小人」配列を追加
Dim j As Long, n As Long, m As Long
With Worksheets("◆Sheet1")
.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, 2)) '◆列方向 C列から 「室」見出し
rr.Select '←↓◆◆デバッグ用追加
MsgBox "この範囲が正味数値データ範囲 " & rr.Address(0, 0)
MonData = rr.Offset(, -2).Resize(, 1).Value
ACdata = rr.Offset(, -1).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) & ACdata(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
Worksheets("◆Sheet2").Activate
End Sub
|
|
kanabun
- 09/1/20(火) 20:25 -
