お世話になります。
役所へ定型で報告をしなければならないのですが、
毎月100名以上の日別に特定条件にものを入力しなければならず、
作業に時間がかかる上に間違いが多いため
VBAで作業時間を短縮したいと考えています。
現状1日ずつのデータを別シートへの転記まではできたのですが、
31回繰り返すために、行を一つずらすたびにすべてのデータを直す必要があるのと、
特定条件が反映されないために困っています。
もし可能であるならば、どこを省略すればよいのか教えていただければ有難いです。
よろしくお願いいたします。
前提・実現したいこと
実現したいこと
シート1「貼付用」の名前、登校時間(1号認定のみ)、降校時間
シート2「転記用」の認定、年齢
をシート3「1号」とシート4「2号」へ下記の要件で転記。
<シート3>
下記のように入力されるようにしたいです。
(1)シート2のC列が新1号,新2号,新3号のどれかで、
かつF列が有の人で、シート1で対象に登園時間が9:00より前に1度でも
来ている人をシート3に抽出して、下記のように転記。
時間帯には朝と入力され、該当者の名前、年齢、9時より前に来た日の時刻を入力。
(2)シート2のC列が新1号,新2号,新3号のどれかで、
かつF列が有の人で、シート1で対象に下校時間が15:30以降に1度でも
下校している人をシート3に抽出して、下記のように入力。
・15時半以降の場合には該当者の名前と年齢、15時半以降になった日の時刻をを入力。
※9;00より前に利用し、かつ15時30分(含む)を利用した人は2行記載される。
登校のみ、もしくは、下校のみ該当した場合は1行記載される。
非該当の人は転記されない。
<シート4>
シート2のC列が1または標かつF列が有の人対象に抽出し、
(1)シート2が1の人は、1か月の間に1回でも16:30以降の場合
D,E列が1,FHに児童名、年齢、該当日の下校時刻(ex.1800)を転記Hに児童名、年齢、該当日の下校時刻(ex.1800)
(2)シート2が標の人は、1か月の間に1回でも18:00以降の場合
D,E列が空白,F
転記するための情報のシートは2つあります。
シート1:貼付用(他ソフトからのCSVをそのまま貼付)
A 整理番号(標準)
B 名前(標準)
C 所属(標準)
D 園(標準)
E 日付(date)
F 曜日(標準)
G 出欠(標準)
H 登校時刻(TIME)
I 外出時刻(TIME)
J 戻り時間(TIME)
K 下校時間(TIME)
シート2:転記用
A 整理番号(標準)
B 名前(標準)
C 認定(標準)…1,新1号,新2号,新3号,標,空白のどれか
D 誕生日(日付)
F 年齢(=DATEDIF(D3,$G$2,"Y"))
F 在籍(標準) …有か無のどちらか
G2~Ak2 〇日(=IF(ISERROR(DATE($A$1,$B$1,〇)),"",IF(MONTH(DATE($A$1,$B$1,〇))=$B$1,DATE($A$1,$B$1,〇),""))
G3~Ak203 時間(TIME)
AL 免除(標準)…1か空白のどちらか
また転記先のシートの情報は下記のとおりです。
シート3:1号
A 番号(標準)
BC 時間帯(標準)…朝か空白のどちらかF 児童名(標準)
D
G,H 年齢(標準)
I25AM40 時刻(標準) 該当時刻を入力するが8:00だった場合800と表示AI 料金(標準)
AN
AQ 実費(標準)
AR 利用料(標準)
AS,AT 利用日数(=IF(AND(D10<>D11,D11=D12),"",IF(D10=D11,SUM(AS10:AS11),AS11)))
AU,AV 免除(標準)
シート4:2号
C 番号(標準)
D,E 標・短(標準) 1か空白のどちらか
F,G 児童名(標準)
I,J 年齢(標準)
K24~AO224 時刻(標準) 該当時刻を入力するが17:00だった場合1700と表示
AP~AR 金額(オリジナル数式を作成予定…同ではない場合は、相当長い数式を入力予定)
AS,AT 免除 1か空白のどちらか
以上です。
■■な機能を実装中に以下のエラーメッセージが発生しました。
発生している問題・エラーメッセージ
転記用に転記する際に、認定で該当する人のものだけを転記しようとしているが、誰も転記されない。 また、1日ごとのコードのため、一つ直すごとにすべての日にちを直す必要があるため、整理がつかなくなっています。
該当のソースコード
Sub 一日() Dim sh1, sh2 Set sh1 = Worksheets("貼付用") Set sh2 = Worksheets("転記") d = sh1.Range("A65536").End(xlUp).Row On Error Resume Next For i = 2 To d '--条件をかけて選別 If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _ sh1.Cells(i, "K") <> "" Then t = sh1.Cells(i, "A") '---Sheet2で時刻行を探す For r = 2 To 200 If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For Next r '--該当行の値をSheet2の時刻該当行セット Sheet2.Cells(r, "B") = sh1.Cells(i, "B") Sheet2.Cells(r, "G") = sh1.Cells(i, "K") End If Next i End Sub
試したこと
認定部分を反映させるために
Sub 一日()
Dim sh1, sh2
Set sh1 = Worksheets("貼付用")
Set sh2 = Worksheets("転記")
d = sh1.Range("A65536").End(xlUp).Row
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh2.Cells(i, "C") = "標" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "K").Value > TimeSerial(17, 59, 99) Then
t = sh1.Cells(i, "A")
'---Sheet2で時刻行を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をSheet2の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
End Sub
や
Sub 一日()
Dim sh1, sh2
Set sh1 = Worksheets("貼付用")
Set sh2 = Worksheets("転記")
d = sh1.Range("A65536").End(xlUp).Row
P_TIME = TimeValue("15:30")
S_TIME = TimeValue("16:30")
L_TIME = TimeValue("18:00")
Certification = sh1.Cells(i, "C")
Select Case Certification
Case Is = "標"
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "k") >= L_TIME Then
t = sh1.Cells(i, "A")
'---Sheet2で整理番号を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をSheet2の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
Case Is = "1"
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "k") >= S_TIME Then
t = sh1.Cells(i, "A")
'---Sheet2で整理番号を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をSheet2の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
Case Else
On Error Resume Next
For i = 2 To d
'--条件をかけて選別
If sh1.Cells(i, "G") = "出席" And sh1.Cells(i, "E") = sh2.Range("G2") And _
sh1.Cells(i, "k") >= P_TIME Then
t = sh1.Cells(i, "A")
'---Sheet2で整理番号を探す
For r = 2 To 1000
If sh1.Cells(i, "A") = sh2.Cells(r, "A") Then Exit For
Next r
'--該当行の値をSheet2の時刻該当行セット
Sheet2.Cells(r, "B") = sh1.Cells(i, "B")
Sheet2.Cells(r, "G") = sh1.Cells(i, "K")
End If
Next i
End Select
End Sub
---本来であれば、
転記シートに一度貼り付けシートの時刻を転記せずに、
そのまま必要部分をシート3およびシート2に転記できればよかったのですが、
一気に別シートまで条件付きでシートを転記する方法が思い浮かばず、
一度転記シートに時間を転記した後に
該当する人のみをート3及びシート4に転記しようとしました。
が、その行為自体は出来る方からすると2度手間かもしれませんので、
省けるのであれば省きたいです。
補足情報(FW/ツールのバージョンなど)
Excel 2019 windows10
ここにより詳細な情報を記載してください。
気になる質問をクリップする
クリップした質問は、後からいつでもMYページで確認できます。
またクリップした質問に回答があった際、通知やメールを受け取ることができます。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
回答7件
0
ベストアンサー
一度に投稿できなかったので、2回目のぶんです。
前に投稿したモジュールに組み込んでください。
VBA
1Public Sub シート1号作成() 2 Dim sh3 As Worksheet 'sheet3 1号 3 Dim sh2 As Worksheet 'sheet2 転記 4 Dim maxrow3 As Long 'shett3 最大行 5 Dim maxrow2 As Long 'sheet2 最大行 6 Dim row3 As Long 'sheet3 行番号 7 Dim row2 As Long 'sheet2 行番号 8 Dim col2 As Long 'sheet2 列番号 9 Dim col3 As Long 'sheet3 列番号 10 Dim endday As Long '月末日 11 Dim wday As Long '処理日 12 Dim wctr As Long '処理件数 13 Dim nintei As String '認定 14 Application.ScreenUpdating = False 15 Application.Calculation = xlCalculationManual 16 17 Set sh3 = Worksheets("1号") 18 Set sh2 = Worksheets("転記") 19 maxrow3 = sh3.Cells(Rows.Count, "A").End(xlUp).Row 'sheet3 最終行を求める 20 maxrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row 'sheet2 最終行を求める 21 '当該月の月末日を取得 22 endday = day(DateSerial(sh2.Cells(1, "A").Value, sh2.Cells(1, "B").Value + 1, 0)) 23 'sheet3の11行以降をクリア 24 For row3 = 11 To maxrow3 25 sh3.Range("A" & row3 & ":AM" & row3).Value = "" 26 sh3.Range("AU" & row3).Value = "" 27 Next 28 row3 = 11 29 'シート2(転記シート)を全行処理する 30 For row2 = 3 To maxrow2 31 nintei = sh2.Cells(row2, "C").Value 32 If (nintei = "新1号" Or nintei = "新2号" Or nintei = "新3号") And sh2.Cells(row2, "F").Value = "有" Then 33 '下校時刻が15:30以降の日があるなら登録する 34 If sh2.Cells(row2, "BS").Value = "1" Then 35 sh3.Cells(row3, "A").Value = row3 - 10 '連番 36 sh3.Cells(row3, "B").Value = "" '時間帯 37 sh3.Cells(row3, "D").Value = sh2.Cells(row2, "B").Value '児童名 38 sh3.Cells(row3, "G").Value = sh2.Cells(row2, "E").Value '年齢 39 wctr = 0 40 '1日~月末日までの繰り返し 41 For wday = 1 To endday 42 col2 = 5 + 2 * wday + 1 43 col3 = 8 + wday 44 If CheckUpperTime(sh2.Cells(row2, col2).Value, 1530) = True Then 45 sh3.Cells(row3, col3).Value = 100 * Hour(sh2.Cells(row2, col2).Value) + Minute(sh2.Cells(row2, col2).Value) 46 wctr = wctr + 1 47 End If 48 Next 49 If wctr = 0 Then 50 MsgBox ("転記シートの" & row2 & "行が不正。15:30以降のデータが1件もありません。データが書き換えられています") 51 GoTo EXIT99 52 End If 53 sh3.Cells(row3, "AU").Value = sh2.Cells(row2, "BQ").Value '免除 54 row3 = row3 + 1 55 End If 56 If sh2.Cells(row2, "BR").Value = "1" Then 57 sh3.Cells(row3, "A").Value = row3 - 10 '連番 58 sh3.Cells(row3, "B").Value = "朝" '時間帯 59 sh3.Cells(row3, "D").Value = sh2.Cells(row2, "B").Value '児童名 60 sh3.Cells(row3, "G").Value = sh2.Cells(row2, "E").Value '年齢 61 wctr = 0 62 '1日~月末日までの繰り返し 63 For wday = 1 To endday 64 col2 = 5 + 2 * wday 65 col3 = 8 + wday 66 If CheckLowerTime(sh2.Cells(row2, col2).Value, 900) = True Then 67 sh3.Cells(row3, col3).Value = 100 * Hour(sh2.Cells(row2, col2).Value) + Minute(sh2.Cells(row2, col2).Value) 68 wctr = wctr + 1 69 End If 70 Next 71 If wctr = 0 Then 72 MsgBox ("転記シートの" & row2 & "行が不正。9:00前のデータが1件もありません。データが書き換えられています") 73 GoTo EXIT99 74 End If 75 sh3.Cells(row3, "AU").Value = sh2.Cells(row2, "BQ").Value '免除 76 row3 = row3 + 1 77 End If 78 End If 79 Next 80 MsgBox ("1号シート作成完了") 81EXIT99: 82 Application.Calculation = xlCalculationAutomatic 83 Application.ScreenUpdating = True 84End Sub 85 86Public Sub シート2号作成() 87 Dim sh4 As Worksheet 'sheet4 2号 88 Dim sh2 As Worksheet 'sheet2 転記 89 Dim maxrow4 As Long 'shett4 最大行 90 Dim maxrow2 As Long 'sheet2 最大行 91 Dim row4 As Long 'sheet4 行番号 92 Dim row2 As Long 'sheet2 行番号 93 Dim col2 As Long 'sheet2 列番号 94 Dim col4 As Long 'sheet4 列番号 95 Dim endday As Long '月末日 96 Dim wday As Long '処理日 97 Dim wctr As Long '処理件数 98 Dim nintei As String '認定 99 Dim etime As Long '下校判定時刻 100 Dim etime_e As String '下校判定時刻(エラーメッセージ用) 101 Dim etime_c As String '下校判定フラグのカラム位置 102 Dim hyou_tan As String '標・短設定 103 Application.ScreenUpdating = False 104 Application.Calculation = xlCalculationManual 105 106 Set sh4 = Worksheets("2号") 107 Set sh2 = Worksheets("転記") 108 maxrow4 = sh4.Cells(Rows.Count, "C").End(xlUp).Row 'sheet4 最終行を求める 109 maxrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row 'sheet2 最終行を求める 110 '当該月の月末日を取得 111 endday = day(DateSerial(sh2.Cells(1, "A").Value, sh2.Cells(1, "B").Value + 1, 0)) 112 'sheet4の15行以降をクリア 113 For row4 = 15 To maxrow4 114 sh4.Range("C" & row4 & ":AO" & row4).Value = "" 115 sh4.Range("AS" & row4).Value = "" 116 Next 117 row4 = 15 118 'シート2(転記シート)を全行処理する 119 For row2 = 3 To maxrow2 120 nintei = sh2.Cells(row2, "C").Value 121 etime = 0 122 If nintei = "1" Then 123 etime = 1630 124 etime_e = "16:30" 125 etime_c = "BT" 126 hyou_tan = "1" 127 End If 128 If nintei = "標" Then 129 etime = 1800 130 etime_e = "18:00" 131 etime_c = "BU" 132 hyou_tan = "" 133 End If 134 If etime <> 0 And sh2.Cells(row2, "F").Value = "有" Then 135 '下校時刻が16:30/18:00以降の日があるなら登録する 136 If sh2.Cells(row2, etime_c).Value = "1" Then 137 sh4.Cells(row4, "C").Value = row4 - 14 '連番 138 sh4.Cells(row4, "D").Value = hyou_tan '標・短 139 sh4.Cells(row4, "F").Value = sh2.Cells(row2, "B").Value '児童名 140 sh4.Cells(row4, "I").Value = sh2.Cells(row2, "E").Value '年齢 141 wctr = 0 142 '1日~月末日までの繰り返し(下校時刻の設定) 143 For wday = 1 To endday 144 col2 = 5 + 2 * wday + 1 145 col4 = 10 + wday 146 If CheckUpperTime(sh2.Cells(row2, col2).Value, etime) = True Then 147 sh4.Cells(row4, col4).Value = 100 * Hour(sh2.Cells(row2, col2).Value) + Minute(sh2.Cells(row2, col2).Value) 148 wctr = wctr + 1 149 End If 150 Next 151 If wctr = 0 Then 152 MsgBox ("転記シートの" & row2 & "行が不正。" & etime_e & "以降のデータが1件もありません。データが書き換えられています") 153 GoTo EXIT99 154 End If 155 sh4.Cells(row4, "AS").Value = sh2.Cells(row2, "BQ").Value '免除 156 row4 = row4 + 1 157 End If 158 End If 159 Next 160 MsgBox ("2号シート作成完了") 161EXIT99: 162 Application.Calculation = xlCalculationAutomatic 163 Application.ScreenUpdating = True 164End Sub 165 166'時間下限チェック(登校時間) 167Private Function CheckLowerTime(ByVal data_time As Variant, check_time As Long) As Boolean 168 CheckLowerTime = False 169 If data_time = "" Then Exit Function 170 If (Hour(data_time) * 100 + Minute(data_time)) < check_time Then 171 CheckLowerTime = True 172 Exit Function 173 End If 174End Function 175'時間上限チェック(下校時間) 176Private Function CheckUpperTime(ByVal data_time As Variant, check_time As Long) As Boolean 177 CheckUpperTime = False 178 If data_time = "" Then Exit Function 179 If (Hour(data_time) * 100 + Minute(data_time)) >= check_time Then 180 CheckUpperTime = True 181 Exit Function 182 End If 183End Function 184 185
投稿2020/09/20 05:08
総合スコア5493
0
既に他の方から回答が出ていますが、参考までにリリースします。
転記シートは私が提示した形のレイアウトに変更してあることが前提になります。
(1日ぶんは登校時刻と下校時刻からなります。又、9:00前の登校、15:30,16:30,18:00以降の下校のフラグが付加されます)
1号シートのデータは11行から出力を開始します。
2号シートのデータは15行から出力を開始します。
1号シート、2号シートの1,2は半角が前提です。
認定の1、新1号、新2号、新3号の1,2,3は半角が前提です。
1号シートの時間帯ですが、9:00前の場合、"朝"を出力します。"1"ではありません。
1号、2号シートの番号も出力します。
kitasueさんのマクロとの違いは以下の点です。
1.貼付用シートに複数の月のデータがあっても問題ありません。該当月のデータのみをピックアップします。2.1号シート、及び2号シートの出力順は、転記シートに記述された児童の並び順です。(kitasueさんのは1号シートのみ整理番号順です。)
3・貼付用シートの並びはそのまま保持されます。(kitasueさんのは整理番号順に並べ替えられます。)
4.1号シート、及び2号シートの出力件数が前回と比べて少なくなっていても問題ありません。
(例として、前回100件出力し、今回80件の場合でも、余分な20件分はクリアされています。事前に1号シート、2号シートの出力部を
手作業でクリアしておく必要はありません)
Public Sub 転記シートへ転記()・・・・貼付用シートから転記シートへ転記
Public Sub シート1号作成()・・・・・転記シートを読み込み、1号シートを作成
Public Sub シート2号作成()・・・・・転記シートを読み込み、2号シートを作成
もし、全てを一気に行いたい場合は、以下のようなプロシージャを作成し追加してください。
Public Sub 一括処理()
Call 転記シートへ転記
Call シート1号作成
Call シート2号作成
End Sub
但し、実際に実行する場合は、エラーが発生しないことを十分に確認したのち、行ってください。
この一括処理は各処理でエラーがあっても、次の処理へ無条件に進みます。
VBA
1Option Explicit 2 3Public Sub 転記シートへ転記() 4 Dim sh1 As Worksheet 'sheet1 貼付用 5 Dim sh2 As Worksheet 'sheet2 転記 6 Dim maxrow1 As Long 'shett1 最大行 7 Dim maxrow2 As Long 'sheet2 最大行 8 Dim row1 As Long 'sheet1 行番号 9 Dim row2 As Long 'sheet2 行番号 10 Dim col2 As Long 'sheet2 列番号 11 Dim dicT As Object '連想配列(キー:整理番号 値:Sheet2の整理番号に対応する行番号) 12 Dim seiri As String '整理番号 13 Dim wyyyy As Long '西暦年 14 Dim wmm As Long '月 15 Application.ScreenUpdating = False 16 Application.Calculation = xlCalculationManual 17 18 Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義 19 Set sh1 = Worksheets("貼付用") 20 Set sh2 = Worksheets("転記") 21 maxrow1 = sh1.Cells(Rows.Count, "A").End(xlUp).Row 'sheet1 最終行を求める 22 maxrow2 = sh2.Cells(Rows.Count, "A").End(xlUp).Row 'sheet2 最終行を求める 23 'sheet2のデータクリア及び整理番号の記憶 24 For row2 = 3 To maxrow2 25 seiri = sh2.Cells(row2, "A").Value 26 dicT(seiri) = row2 '整理番号と行番号を登録 27 sh2.Range("G" & row2 & ":BP" & row2).Value = "" 'G~BPをクリア 28 sh2.Range("BR" & row2 & ":BU" & row2).Value = "" 'BR~BUをクリア 29 Next 30 'sheet1を全行処理する 31 For row1 = 2 To maxrow1 32 If sh1.Cells(row1, "G").Value = "出席" And sh1.Cells(row1, "K").Value <> "" Then 33 '整理番号がsheet2に存在するかチェックする 34 seiri = sh1.Cells(row1, "A").Value 35 If dicT.Exists(seiri) = False Then 36 MsgBox ("貼付用シート:" & row1 & "行の整理番号:" & seiri & "は転記シートに存在しません。処理を中止します。") 37 GoTo EXIT99 38 End If 39 '日付の年・月が転記シートの年・月に一致するかチェックする 40 wyyyy = Year(sh1.Cells(row1, "E").Value) 41 wmm = Month(sh1.Cells(row1, "E").Value) 42 If wyyyy = sh2.Cells(1, "A").Value And wmm = sh2.Cells(1, "B").Value Then 43 '年月が一致なら該当日へ登録する 44 row2 = dicT(seiri) 'sheet2の登録対象の行番号取得 45 col2 = day(sh1.Cells(row1, "E").Value) * 2 + 5 'sheet2の登録対象の列番号取得(該当日付の列) 46 '園児名登録 47 sh2.Cells(row2, "B").Value = sh1.Cells(row1, "B").Value 48 '登校時刻登録 49 sh2.Cells(row2, col2) = sh1.Cells(row1, "H").Value 50 '下校時刻登録 51 sh2.Cells(row2, col2 + 1) = sh1.Cells(row1, "K").Value 52 '登校時間チェック 53 If CheckLowerTime(sh1.Cells(row1, "H").Value, 900) = True Then 54 sh2.Cells(row2, "BR").Value = "1" 55 End If 56 '下校時間チェック 57 If CheckUpperTime(sh1.Cells(row1, "K").Value, 1530) = True Then 58 sh2.Cells(row2, "BS").Value = "1" 59 End If 60 If CheckUpperTime(sh1.Cells(row1, "K").Value, 1630) = True Then 61 sh2.Cells(row2, "BT").Value = "1" 62 End If 63 If CheckUpperTime(sh1.Cells(row1, "K").Value, 1800) = True Then 64 sh2.Cells(row2, "BU").Value = "1" 65 End If 66 End If 67 End If 68 Next 69 MsgBox ("転記シート設定完了") 70EXIT99: 71 Application.Calculation = xlCalculationAutomatic 72 Application.ScreenUpdating = True 73End Sub 74 75 76
投稿2020/09/20 05:05
総合スコア5493
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
0
[1号]シートの更新のコードです。
VBA
1Option Explicit 2 3Const RowHari明細 = 2 4Const ColHari出席番号 = "A" 5Const ColHari名前 = "B" 6Const ColHari日付 = "E" 7Const ColHari登校時刻 = "H" 8Const ColHari降校時刻 = "K" 9Const RowTenk明細 = 3 10Const ColTenk整理番号 = "A" 11Const ColTenk園児名 = "B" 12Const ColTenk認定 = "C" 13Const ColTenk年齢 = "E" 14Const ColTenk在籍 = "F" 15Const ColTenk1日 = "G" 16Const ColTenk免除 = "AL" 17Const Row1gou明細 = 11 18Const Col1gou時間帯 = "B" 19Const Col1gou児童名 = "D" 20Const Col1gou年齢 = "G" 21Const Col1gou1日 = "I" 22Const Col1gou免除 = "AU" 23Const Row2gou明細 = 15 24Const Col2gou標短 = "D" 25Const Col2gou児童名 = "F" 26Const Col2gou年齢 = "i" 27Const Col2gou1日 = "K" 28Const Col2gou免除 = "AS" 29 30Sub s_set1gou() 31 32 Dim wshHari As Worksheet 33 Dim lngHariRow As Long 34 Dim lngHariRowEnd As Long 35 Dim varHari出席番号 As Variant 36 Dim datHari登校時刻 As Date 37 Dim datHari降校時刻 As Date 38 Dim lngHariDay As Long 39 Dim wshTenk As Worksheet 40 Dim lngTenkRow As Long 41 Dim lngTenkRowEnd As Long 42 Dim strTenk認定 As String 43 Dim dctTenk整理番号Row As Dictionary 44 Dim wsh1gou As Worksheet 45 Dim lng1gouRow As Long 46 Dim str1gou整理番号 As String 47 Dim lng1gou朝夕区分 As Long 48 Set wshHari = Worksheets("貼付用") 49 Set wshTenk = Worksheets("転記") 50 Set wsh1gou = Worksheets("1号") 51 Set dctTenk整理番号Row = New Dictionary 52 53'[貼付用]シートを[出席番号]の昇順、[降校時刻]の降順でソート 54 55 With wshHari.Sort 56 .SortFields.Clear 57 .SortFields.Add wshHari.Cells(1, ColHari出席番号), Order:=xlAscending 58 .SortFields.Add wshHari.Cells(1, ColHari降校時刻), Order:=xlDescending 59 .SetRange wshHari.Range(ColHari出席番号 & ":" & ColHari降校時刻) 60 .Header = xlYes 61 .Apply 62 End With 63 64'[転記]シートの[整理番号]の行番号をDictionaryに登録 65 66 lngTenkRowEnd = wshTenk.Cells(wshTenk.Rows.Count, ColTenk整理番号).End(xlUp).Row 67 For lngTenkRow = RowTenk明細 To lngTenkRowEnd 68 dctTenk整理番号Row.Add wshTenk.Cells(lngTenkRow, ColTenk整理番号).Value, lngTenkRow 69 Next lngTenkRow 70 71'[1号]シートの更新 72 73 lng1gouRow = Row1gou明細 - 1 74 lngHariRowEnd = wshHari.Cells(wshHari.Rows.Count, ColHari出席番号).End(xlUp).Row 75 For lngHariRow = RowHari明細 To lngHariRowEnd 76 77'[転記]シートの[整理番号]の行番号を取得 78 79 varHari出席番号 = wshHari.Cells(lngHariRow, ColHari出席番号).Value 80 If dctTenk整理番号Row.Exists(varHari出席番号) = False Then 81 MsgBox varHari出席番号 & "が存在しません。" 82 GoTo s_set1gou_Exit 83 End If 84 lngTenkRow = dctTenk整理番号Row.Item(varHari出席番号) 85 86 strTenk認定 = wshTenk.Cells(lngTenkRow, ColTenk認定) 87 If (strTenk認定 = "新1号" Or strTenk認定 = "新2号" Or strTenk認定 = "新3号") And wshTenk.Cells(lngTenkRow, ColTenk在籍) = "有" Then 88'夕 89 datHari降校時刻 = wshHari.Cells(lngHariRow, ColHari降校時刻).Value 90 If datHari降校時刻 >= TimeValue("15:30") Then 91 lngHariDay = Day(wshHari.Cells(lngHariRow, ColHari日付).Value) 92 If str1gou整理番号 = varHari出席番号 Then 93 If lng1gou朝夕区分 = 2 Then 94 wsh1gou.Cells(lng1gouRow, Col1gou1日).Offset(, lngHariDay - 1).Value = Format(datHari降校時刻, "hmm") 95 Else 96 wsh1gou.Cells(lng1gouRow - 1, Col1gou1日).Offset(, lngHariDay - 1).Value = Format(datHari降校時刻, "hmm") 97 End If 98 Else 99 lng1gouRow = lng1gouRow + 1 100 str1gou整理番号 = varHari出席番号 101 lng1gou朝夕区分 = 2 102 wsh1gou.Cells(lng1gouRow, Col1gou児童名).Value = wshTenk.Cells(lngTenkRow, ColTenk園児名).Value 103 wsh1gou.Cells(lng1gouRow, Col1gou年齢).Value = wshTenk.Cells(lngTenkRow, ColTenk年齢).Value 104 wsh1gou.Cells(lng1gouRow, Col1gou1日).Offset(, lngHariDay - 1).Value = Format(datHari降校時刻, "hmm") 105 wsh1gou.Cells(lng1gouRow, Col1gou免除).Value = wshTenk.Cells(lngTenkRow, ColTenk免除).Value 106 End If 107 End If 108'朝 109 datHari登校時刻 = wshHari.Cells(lngHariRow, ColHari登校時刻).Value 110 If datHari登校時刻 < TimeValue("09:00") Then 111 lngHariDay = Day(wshHari.Cells(lngHariRow, ColHari日付).Value) 112 If str1gou整理番号 = varHari出席番号 And lng1gou朝夕区分 = 1 Then 113 wsh1gou.Cells(lng1gouRow, Col1gou1日).Offset(, lngHariDay - 1).Value = Format(datHari登校時刻, "hmm") 114 Else 115 lng1gouRow = lng1gouRow + 1 116 str1gou整理番号 = varHari出席番号 117 lng1gou朝夕区分 = 1 118 wsh1gou.Cells(lng1gouRow, Col1gou時間帯).Value = 1 119 wsh1gou.Cells(lng1gouRow, Col1gou児童名).Value = wshTenk.Cells(lngTenkRow, ColTenk園児名).Value 120 wsh1gou.Cells(lng1gouRow, Col1gou年齢).Value = wshTenk.Cells(lngTenkRow, ColTenk年齢).Value 121 wsh1gou.Cells(lng1gouRow, Col1gou1日).Offset(, lngHariDay - 1).Value = Format(datHari登校時刻, "hmm") 122 wsh1gou.Cells(lng1gouRow, Col1gou免除).Value = wshTenk.Cells(lngTenkRow, ColTenk免除).Value 123 End If 124 End If 125 End If 126 Next lngHariRow 127 128s_set1gou_Exit: 129 130 Set dctTenk整理番号Row = Nothing 131 Set wsh1gou = Nothing 132 Set wshTenk = Nothing 133 Set wshHari = Nothing 134 135End Sub
投稿2020/09/19 06:14
編集2020/09/21 07:48総合スコア314
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/09/19 07:40
2020/09/19 08:02
2020/09/19 08:18
2020/09/19 08:23
2020/09/19 08:54
2020/09/21 07:27 編集
2020/09/21 07:47
2020/09/21 08:13
2020/09/21 09:59
2020/09/28 02:31
0
[2号]シートの更新のコードです。
VBA
1Option Explicit 2 3Const RowHari明細 = 2 4Const ColHari出席番号 = "A" 5Const ColHari名前 = "B" 6Const ColHari日付 = "E" 7Const ColHari登校時刻 = "H" 8Const ColHari降校時刻 = "K" 9Const RowTenk明細 = 3 10Const ColTenk整理番号 = "A" 11Const ColTenk園児名 = "B" 12Const ColTenk認定 = "C" 13Const ColTenk年齢 = "E" 14Const ColTenk在籍 = "F" 15Const ColTenk1日 = "G" 16Const ColTenk免除 = "AL" 17Const Row2gou明細 = 15 18Const Col2gou標短 = "D" 19Const Col2gou児童名 = "F" 20Const Col2gou年齢 = "i" 21Const Col2gou1日 = "K" 22Const Col2gou免除 = "AS" 23 24Sub s_set2gou() 25 Dim lngRowTenk As Long 26 Dim lngRowTenkEnd As Long 27 Dim lngRow2gou As Long 28 Dim lngCol As Long 29 Dim str認定 As String 30 Dim lngRowInc As Long 31 Dim dat時刻 As Date 32 33 Dim wshTenk As Worksheet 34 Dim wsh2gou As Worksheet 35 36 Set wshTenk = Worksheets("転記") 37 Set wsh2gou = Worksheets("2号") 38 39 lngRow2gou = Row2gou明細 40 lngRowTenkEnd = wshTenk.Cells(wshTenk.Rows.Count, ColTenk整理番号).End(xlUp).Row 41 For lngRowTenk = RowTenk明細 To lngRowTenkEnd 42 lngRowInc = 0 43 str認定 = wshTenk.Cells(lngRowTenk, ColTenk認定).Value 44 If (str認定 = "1" Or str認定 = "標") And wshTenk.Cells(lngRowTenk, ColTenk在籍).Value = "有" Then 45 For lngCol = 1 To 31 46 dat時刻 = wshTenk.Cells(lngRowTenk, ColTenk1日).Offset(, lngCol - 1).Value 47 If str認定 = "1" And dat時刻 >= TimeValue("16:30") Or _ 48 str認定 = "標" And dat時刻 >= TimeValue("18:00") Then 49 If lngRowInc = 0 Then 50 If str認定 = "1" Then 51 wsh2gou.Cells(lngRow2gou, Col2gou標短).Value = 1 52 End If 53 wsh2gou.Cells(lngRow2gou, Col2gou児童名).Value = wshTenk.Cells(lngRowTenk, ColTenk園児名).Value 54 wsh2gou.Cells(lngRow2gou, Col2gou年齢).Value = wshTenk.Cells(lngRowTenk, ColTenk年齢).Value 55 wsh2gou.Cells(lngRow2gou, Col2gou免除).Value = wshTenk.Cells(lngRowTenk, ColTenk免除).Value 56 End If 57 wsh2gou.Cells(lngRow2gou, Col2gou1日).Offset(, lngCol - 1).Value = Format(dat時刻, "hmm") 58 lngRowInc = 1 59 End If 60 Next lngCol 61 End If 62 lngRow2gou = lngRow2gou + lngRowInc 63 Next lngRowTenk 64 65 Set wsh2gou = Nothing 66 Set wshTenk = Nothing 67 68End Sub
投稿2020/09/19 03:21
総合スコア314
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/09/19 06:50 編集
2020/09/19 19:07 編集
2020/09/19 08:14
2020/09/19 08:21
2020/09/21 07:35
2020/09/21 07:46
0
変更後の転記シートです。
緑の部分がマクロで設定する個所です。
今考えているのは、以下の1案のほうです。
1案
転記シートへの転記の際は、登校時刻と下校時刻を無条件に全て設定する。
そして、1号と2号へ転記時に必要な時刻のみを設定する。
2案
転記シートへの転記の際、認定の内容を読み込み、1号、2号へ転記時に必要な時刻のみを設定する。
例1 認定が標の場合
下校時刻が18:00以降のみの下校時刻のみを転記シートへ設定する。
登校時刻はいかなる時刻であっても転記シートへ設定しない。
例2 認定が新1号、新2号、新3号の何れかの場合
登校時間が9:00より前の場合、登校時刻を転記シートへ設定する。
下校時刻は、15:30以降の場合、下校時刻を転記シートへ設定する。
1案であれば、転記シートに全ての情報があるので、後でチェックがきちんとできると考えています。
2案を望まれるのであれば、そのようにすることは可能です。
投稿2020/09/19 01:19
編集2020/09/19 02:42総合スコア5493
0
とりあえず、まずは、[転記]シートへの転記の部分だけ作ってみました。
VBEの「ツール>参照設定」から「Microsoft Scripting Runtime」へ参照設定してください。
異なる月のデータの混在が無いことが前提です。
VBA
1Option Explicit 2 3Const RowHari明細 = 2 4Const ColHari出席番号 = "A" 5Const ColHari名前 = "B" 6Const ColHari日付 = "E" 7Const ColHari登校時刻 = "H" 8Const ColHari降校時刻 = "K" 9Const RowTenk明細 = 3 10Const ColTenk整理番号 = "A" 11Const ColTenk園児名 = "B" 12Const ColTenk認定 = "C" 13Const ColTenk年齢 = "E" 14Const ColTenk在籍 = "F" 15Const ColTenk1日 = "G" 16Const ColTenk免除 = "AL" 17 18Sub s_setTenk() 19 20 Dim lngRowHari As Long 21 Dim lngRowHariEnd As Long 22 Dim lngRowTenk As Long 23 Dim lngRowTenkEnd As Long 24 Dim wshHari As Worksheet 25 Dim wshTenk As Worksheet 26 Dim lngDay As Long 27 Dim dat降校時刻 As Date 28 Dim dctRow整理番号 As Dictionary 29 Dim var整理番号 As Variant 30 31 Set wshHari = Worksheets("貼付用") 32 Set wshTenk = Worksheets("転記") 33 Set dctRow整理番号 = New Dictionary 34 35 lngRowTenkEnd = wshTenk.Cells(wshTenk.Rows.Count, ColTenk整理番号).End(xlUp).Row 36 For lngRowTenk = RowTenk明細 To lngRowTenkEnd 37 dctRow整理番号.Add wshTenk.Cells(lngRowTenk, ColTenk整理番号).Value, lngRowTenk 38 Next lngRowTenk 39 40 lngRowHariEnd = wshHari.Cells(wshHari.Rows.Count, ColHari出席番号).End(xlUp).Row 41 For lngRowHari = RowHari明細 To lngRowHariEnd 42 var整理番号 = wshHari.Cells(lngRowHari, ColHari出席番号).Value 43 If dctRow整理番号.Exists(var整理番号) = False Then 44 MsgBox var整理番号 & "が存在しません。", vbExclamation 45 GoTo s_setTenk_Exit 46 End If 47 lngRowTenk = dctRow整理番号.Item(var整理番号) 48 wshTenk.Cells(lngRowTenk, ColTenk園児名).Value = wshHari.Cells(lngRowHari, ColHari名前).Value 49 If wshHari.Cells(lngRowHari, ColHari降校時刻).Value <> "" Then 50 lngDay = Day(wshHari.Cells(lngRowHari, ColHari日付).Value) 51 dat降校時刻 = wshHari.Cells(lngRowHari, ColHari降校時刻).Value 52 Select Case wshTenk.Cells(lngRowTenk, ColTenk認定) 53 Case "標" 54 If dat降校時刻 >= TimeValue("18:00") Then 55 wshTenk.Cells(lngRowTenk, ColTenk1日).Offset(, lngDay - 1) = wshHari.Cells(lngRowHari, ColHari降校時刻).Value 56 End If 57 Case "1" 58 If dat降校時刻 >= TimeValue("16:30") Then 59 wshTenk.Cells(lngRowTenk, ColTenk1日).Offset(, lngDay - 1) = wshHari.Cells(lngRowHari, ColHari降校時刻).Value 60 End If 61 Case "新1号", "新2号", "新3号" 62 If dat降校時刻 >= TimeValue("15:30") Then 63 wshTenk.Cells(lngRowTenk, ColTenk1日).Offset(, lngDay - 1) = wshHari.Cells(lngRowHari, ColHari降校時刻).Value 64 End If 65 End Select 66 End If 67 Next lngRowHari 68 69s_setTenk_Exit: 70 71 Set dctRow整理番号 = Nothing 72 Set wshTenk = Nothing 73 Set wshHari = Nothing 74 75End Sub
投稿2020/09/19 01:16
編集2020/09/19 07:54総合スコア314
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/09/19 05:55
2020/09/19 06:19
2020/09/19 06:38
2020/09/19 08:02
0
回答ではありません。いくつか不明点があるので質問です。
1.サンプルの貼付用シートの日付は2020年9月ですが、転記用シートの日付は2020年10月です。
貼付用シートには9月とか10月とかの複数の月のデータがあるということでしょうか。
(転記用は2020年10月のみで、ひと月のデータだけということは理解できます)
2.貼付用シートの出席番号(整理番号)が、転記用シートに存在しないというケースはあり得ないと考えて良いですか。
(あるとしたら、データの記述ミス)
3.マクロで転記シートに転記するのは、下校時間と園児名であってますか。
また、次のステップでは、この転記シートのデータを読み込んで、1号、2号のデータを作成するマクロを作りたいということでしょうか。
(以降の質問はその前提での質問です)
4.1号シートの作成について
①「(1)シート2のC列が新1号,新2号,新3号のどれかで、
かつF列が有の人で、シート1で対象に登園時間が9:00より前に1度でも
来ている人をシート3に抽出して、下記のように入力。
時間帯には朝と入力され、該当者の名前、年齢、9時より前に来た日の時刻を入力。」
とありますが、その場合、必ず2行を出力するのですか。
1行目の時間帯は空白、各日付の時刻は下校時刻
2行目の時間帯は朝、各日付の時刻は登校
又「シート2のC列が新1号,新2号,新3号のどれかで、かつF列が有の人で、かつ登園時間が全て9:00以降の人」は、シート3に抽出しないのでしょうか。
②「(2)シート2のC列が新1号,新2号,新3号のどれかで、
かつF列が有の人で、シート1で対象に下校時間が15:30以降に1度でも
下校している人をシート3に抽出して、下記のように入力。」
とありますが、その場合、1行のみを出力するのですか。
(各日付の時刻は下校時刻だが、15:30以前の時刻も記入して良いのか。15:30以降の時刻のみ記入するのかが不明)
又15:30以降とは15:30を含むのか含まないのかが不明。
又「シート2のC列が新1号,新2号,新3号のどれかで、かつF列が有の人で、かつ下校時間が全て15:30以前の人」は、シート3に抽出しないのでしょうか。
③以下のケースの場合、どのようになりますか。(以下の人は全て、シート2のC列が新1号かつF列が有り)
Aさん 10月1日 登校9:00 下校14:00 以外の日は全て休み
Bさん 10月1日 登校8:00 下校14:00 以外の日は全て休み
Cさん 10月1日 登校9:00 下校16:30 以外の日は全て休み
Dさん 10月1日 登校8:00 下校16:30 以外の日は全て休み
5.2号シートの作成について
①「(1)シート2が1の人は、1か月の間に1回でも16:30以降D,E列が1,F~Hに児童名、該当日の下校時刻(ex.1800)」
とありますが、該当日の下校時刻のみ、出力すれば良いのですか。(下校時刻が16:30より前の日の個所は出力しない。)
②「(2)シート2が標の人は、1か月の間に1回でも18:00以降D,E列が空白,F~Hに児童名、該当日の下校時刻(ex.1800)」
とありますが、該当日の下校時刻のみ、出力すれば良いのですか。(下校時刻が18:00より前の日の個所は出力しない。)
以上が質問になります。
以下は質問ではありません。提案です。
役所へ提出するのは1号、2号のみで、貼付用シート、転記シートは提出しないと理解しました。
1号、2号のシートへ出力時、貼付用シートと転記用シートを参照していますが、これを転記用シートのみ参照するように
してはいかがでしょうか。
その為、以下のような情報が転記シートに追加になります。
①登校時刻
②登校判定フラグ(登校時刻が1日でも以上9:00以前の日があれば1、以外は空白)
③下校判定フラグ1(下校時刻が1日でも15:30以降の日があれば1、以外は空白)
④下校判定フラグ2(下校時刻が1日でも16:30以降の日があれば1、以外は空白)
⑤下校判定フラグ3(下校時刻が1日でも18:30以降の日があれば1、以外は空白)
以上。
投稿2020/09/18 09:40
編集2020/09/18 22:06総合スコア5493
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/09/18 23:01
2020/09/19 01:18
2020/09/19 02:19
2020/09/19 04:23
あなたの回答
tips
太字
斜体
打ち消し線
見出し
引用テキストの挿入
コードの挿入
リンクの挿入
リストの挿入
番号リストの挿入
表の挿入
水平線の挿入
プレビュー
質問の解決につながる回答をしましょう。 サンプルコードなど、より具体的な説明があると質問者の理解の助けになります。 また、読む側のことを考えた、分かりやすい文章を心がけましょう。
バッドをするには、ログインかつ
こちらの条件を満たす必要があります。
2020/09/21 07:19
2020/09/21 08:28
2020/09/21 08:43 編集
2020/09/23 02:55
2020/09/23 03:00
2020/09/28 01:55
2020/09/28 01:58