[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『欠席数と欠席率をまとめたい』（ジョニー）
下記Sheet1に、2015年2月の保育園の出欠実績があります。 A2 2/3のさくら組の出席数は12名で、欠席数は3名。 欠席数の内訳けとして、E2 F2には腹痛が1名。G2 H2にはｲﾝﾌﾙAが2名というような データがあります。 保育園全組のまとめを月ごとに、Sheet2(欠席数)に抽出していきたいと思ってい ます。 Sheet3(欠席率)には、全出席数71日+全欠席数15=86を分母とし、分子にSheet2(欠席数) になります。 *Sheet1の実際のデータは理由10 欠席数10まであります。 *Sheet2とSheet3の欠席理由は固定されあらかじめ、セットされています。 *Sheet2のH1は基準月（Sheet1のデータの年月）です。 ご指導よろしくお願いします。
Sheet1
A B C D E F G H I J
1 日付 組 出席数 欠席数 理由1 欠席数1 理由2 欠席数2 理由3 欠席数3
2 2/3 さくら 12 3 腹痛 1 ｲﾝﾌﾙA 2
3 2/3 うめ 11 3 ｲﾝﾌﾙA 2 ｲﾝﾌﾙB 1
4 2/3 たけ 13 1 頭痛 1
5 2/4 さくら 13 2 ｲﾝﾌﾙA 1 ｲﾝﾌﾙB 1
6 2/4 うめ 9 5 ｲﾝﾌﾙB 3 骨折 1 下痢 1
7 2/4 たけ 13 1 頭痛 1
Sheet2(欠席数)
A B C D E F G H
1 腹痛 ｲﾝﾌﾙA ｲﾝﾌﾙB 頭痛 骨折 下痢 2015/2
2 2月 1 5 5 2 1 1
3 3月
4 4月
Sheet3(欠席率)
A B C D E F G
1 腹痛 ｲﾝﾌﾙA ｲﾝﾌﾙB 頭痛 骨折 下痢
2 2月 1.2% 5.8% 5.8% 2.3% 1.2% 1.2%
3 3月
4 4月
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
Sub aaa()
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
a = 2
b = 6
c = 0
d = 2
Do Until d = 5
Do Until a = 8
If Month(Cells(a, 2).Value) = d Then
Do Until b = 26
If Cells(a, b).Value = "腹痛" Then
c = c + Cells(a, b + 1).Value
End If
b = b + 2
Loop
Sheets(2).Cells(d, 2).Value = c + Sheets(2).Cells(d, 2).Value
c = 0
b = 6
Do Until b = 26
If Cells(a, b).Value = "ｲﾝﾌﾙA" Then
c = c + Cells(a, b + 1).Value
End If
b = b + 2
Loop
Sheets(2).Cells(d, 3).Value = c + Sheets(2).Cells(d, 3).Value
c = 0
b = 6
Do Until b = 26
If Cells(a, b).Value = "ｲﾝﾌﾙB" Then
c = c + Cells(a, b + 1).Value
End If
b = b + 2
Loop
Sheets(2).Cells(d, 4).Value = c + Sheets(2).Cells(d, 4).Value
c = 0
b = 6
Do Until b = 26
If Cells(a, b).Value = "頭痛" Then
c = c + Cells(a, b + 1).Value
End If
b = b + 2
Loop
Sheets(2).Cells(d, 5).Value = c + Sheets(2).Cells(d, 5).Value
c = 0
b = 6
Do Until b = 26
If Cells(a, b).Value = "骨折" Then
c = c + Cells(a, b + 1).Value
End If
b = b + 2
Loop
Sheets(2).Cells(d, 6).Value = c + Sheets(2).Cells(d, 6).Value
c = 0
b = 6
Do Until b = 26
If Cells(a, b).Value = "下痢" Then
c = c + Cells(a, b + 1).Value
End If
b = b + 2
Loop
b = 6
Sheets(2).Cells(d, 7).Value = c + Sheets(2).Cells(d, 7).Value
c = 0
End If
a = a + 1
Loop
a = 2
d = d + 1
Loop
End Sub
これは理由が下痢まである場合のマクロなので、あとは付け足してください。こちらとしては７つめ以降の理由がわからないのでどうしようもありません。
（スズメ） 2015/03/28(土) 11:14
Dim a As Long
Dim b As Long
Dim c As Long
Dim d As Long
と、
a = 2
b = 6
c = 0
d = 2
の間に、
Sheets(2).Range("B2:G2").ClearContentsを付け足してください。
（スズメ） 2015/03/28(土) 11:20
＞ *Sheet2とSheet3の欠席理由は固定されあらかじめ、セットされています。 ＞ *Sheet1の実際のデータは理由10 欠席数10まであります。
１．・・・と言うことは、実際はK列まで欠席理由が書かれているんですね？
＞ *Sheet2のH1は基準月（Sheet1のデータの年月）です。
２．何の為に基準月なんて書き込むのですか？ Sheet1が2月分なら書く必要ないような気がするんですけど、 実際は、1月分とか3月分もSheet2に混在しているのですか？
３．混在している場合、当然、集計基準月を書く必要がある訳ですけど
実際はどのセルに書いてあるんですか？
（H1セルじゃないことは明らかですけど。L列なんでしょうか？）
４．・・・で、「2015/2」これはどんなデータなんですか？（文字列？ 日付シリアル値？）
５．同じような疑問ですけど、Sheet2とSheet3のA列「3月」とかは、
どんなデータなんですか？（文字列？ 日付シリアル値？）
（半平太） 2015/03/28(土) 17:40
半平太さま、ありがとうございます。 １．・・・と言うことは、実際はK列まで欠席理由が書かれているんですね？
欠席理由は1から10まであり、欠席理由10はW列が最終で、欠席数10はX列になります。
Sheet1
A B C D E F G H I J W X
1 日付 組 出席数 欠席数 理由1 欠席数1 理由2 欠席数2 理由3 欠席数3 ・・・理由10 欠席数10
2．何の為に基準月なんて書き込むのですか？
Sheet2やSheet3に転記する時に必要かと考えました。
3月分や4月分をするとき2月分が消えてしまわないかと。
不要なら無視してください。
Sheet1のデータは2月分だけです。３月が終わると３月分だけです。混在はありません。
4．・・・で、「2015/2」これはどんなデータなんですか？
5．同じような疑問ですけど、Sheet2とSheet3のA列「3月」とかは、
どんなデータなんですか？（文字列？ 日付シリアル値？）
日付はすべてシリアル値です。
私のスキル不足で、的外れな事を書いてるようですみません。
ご指導よろしくお願いします。
（ジョニー） 2015/03/28(土) 18:57
欠席集計シートと欠席率シートの欠席理由はB1:L1に書いてあるものとします。（下図参照） 但し、順序は不問。 また、該当する月データがA列に無い場合は、最下行の下に自動的に追加されることにします。
<Sheet2 結果図> 行 _______A_______ __B__ __C__ __D__ __E__ __F__ __G__ __H__ __I__ __J__ ___K___ 1 テキトーな日付 腹痛 ｲﾝﾌﾙA ｲﾝﾌﾙB 頭痛 骨折 下痢 理由7 理由8 理由9 その他 2 2015/1/15 3 2015/2/3 1 5 5 2 1 1 4 2015/3/3 5 2015/4/7
<Sheet3 結果図> 行 _______A_______ __B__ __C__ __D__ __E__ __F__ __G__ __H__ __I__ __J__ ___K___ 1 テキトーな日付 腹痛 ｲﾝﾌﾙA ｲﾝﾌﾙB 頭痛 骨折 下痢 理由7 理由8 理由9 その他 2 2015/2/28 1.2% 5.8% 5.8% 2.3% 1.2% 1.2% 3 2015/3/15 4 2015/4/6
<Sheet2 結果図> もし月の情報が無い場合は、最下行の下に自動追加される。（日付はSheet1のA2セルと同じものにセット）
行 _______A_______ __B__ __C__ __D__ __E__ __F__ __G__ __H__ __I__ __J__ ___K___ 1 テキトーな日付 腹痛 ｲﾝﾌﾙA ｲﾝﾌﾙB 頭痛 骨折 下痢 理由7 理由8 理由9 その他 2 2015/1/15 3 ←テストの為、2月の日付をクリアして実行すると 4 2015/3/3 5 2015/4/7 6 2015/2/3 1 5 5 2 1 1 ←2月が見当たらないので自動追加される
※セルの書式はそちらで設定してください。
貼り付けるマクロ
Sub ReasonsToBeAbsent()
Dim rollSh As Worksheet, reasonSh As Worksheet, ratioSh As Worksheet
Dim dic As Object
Dim cel As Range
Dim yearnmonth As String
Dim rowToWriteReason As Long '書込み行番号
Dim rowToWriteRatio As Long
Dim TTL As Long
Set rollSh = Worksheets("Sheet1") '出欠シート
Set reasonSh = Worksheets("Sheet2") '欠席集計シート
Set ratioSh = Worksheets("Sheet3") '欠席率シート
Set dic = CreateObject("Scripting.Dictionary") ' 連想配列をセット
For Each cel In rollSh.Range("E2:X" & rollSh.Range("A10000").End(xlUp).Row)
If Application.IsText(cel.Value) Then
If IsNumeric(cel.Offset(, 1).Value) Then
If dic.Exists(cel.Value) Then
dic(cel.Value) = dic(cel.Value) + cel.Offset(, 1).Value
Else
dic(cel.Value) = cel.Offset(, 1).Value
End If
End If
End If
Next
TTL = Application.Sum(rollSh.Range("C:D")) '分母
yearnmonth = Format(rollSh.Range("A2").Value, "yyyymm")
rowToWriteReason = RowNumToWrite(reasonSh, yearnmonth, rollSh.Range("A2").Value)
rowToWriteRatio = RowNumToWrite(ratioSh, yearnmonth, rollSh.Range("A2").Value)
For Each cel In reasonSh.Range("B1:L1")
If dic.Exists(cel.Value) Then
reasonSh.Cells(rowToWriteReason, cel.Column).Value = dic(cel.Value)
End If
Next
For Each cel In ratioSh.Range("B1:L1")
If dic.Exists(cel.Value) Then
ratioSh.Cells(rowToWriteRatio, cel.Column).Value = dic(cel.Value) / TTL
End If
Next
dic.RemoveAll
End Sub
Function RowNumToWrite(wsToWrite As Worksheet, ByVal yearnmonth As String, ByVal defaultDate)
Dim cel As Range
For Each cel In wsToWrite.Range("A2", wsToWrite.Range("A500").End(xlUp))
If Format(cel.Value, "yyyymm") = yearnmonth Then
RowNumToWrite = cel.Row
Exit For
End If
Next
If RowNumToWrite = 0 Then '書き込むベキ月の情報がA列に無い場合
With wsToWrite.Range("A500").End(xlUp).Offset(1)
RowNumToWrite = .Row
.Value = defaultDate
End With
End If
End Function （半平太） 2015/03/28(土) 22:25
半平太さま、確認させていただきました。 完璧です。 2月の日付をクリアして、実行させると自動的に追加されるところまで考えていただき 感謝しております。 ありがとうございました。
（ジョニー） 2015/03/28(土) 23:18
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.