シート毎に指定の行で処理を飛ばす

Question

勤怠登録をVBAで作成しています。
10月、11月、12月と三枚のシートがあり、日付を選択して出勤日を登録するようになっています。

現状、32行目まで空白のセルを上から埋めて次のシートへ飛ぶループ処理にしていますが
土日に出勤しない場合32行目までいくまえに終わってしまいます。
月によって何日が土日かも違うので、シートごとに指定のセルを飛ばして処理
するしか発想が無いのですが、他にもやり方があれば教えていただけますでしょうか。

発生している問題・エラーメッセージ

エラーメッセージ

該当のソースコード

Private Sub cb_touroku_Click()                      '年月日出勤時刻登録ボタン
    Dim tgtRow As Long
    tgtRow = Cells(30, 1).End(xlUp).Row
    tgtRow = tgtRow + 1

For i = 2 To 32

For Each SH In ActiveWorkbook.Worksheets
       With ActiveSheet
        .Cells(tgtRow, 1).Value = DateSerial(Me.cb1.Value, Me.cb2.Value, Me.cb3.Value)'年月日
        .Cells(tgtRow, 2).Value = TimeSerial(Me.TextBox1.Value, Me.TextBox2.Value, 0) '出勤時刻
    End With
  
Next
Next i
    MsgBox "登録しました"
    
    'ここのlabel1に来たら
    'GoTo label1
    
'この部分は実行されません
    
    'Range("A3") = r
   ' Range("B3") = r
    'Range("C3") = r
 
'label1:
       
End Sub

Private Sub cb_touroku2_Click()               '退勤・休憩登録
   Dim tgtRow As Long
    tgtRow = Cells(30, 1).End(xlUp).Row

For r = 2 To 32

For Each SH In ActiveWorkbook.Worksheets
       With ActiveSheet
        .Cells(tgtRow, 3).Value = TimeSerial(Me.TextBox3.Value, Me.TextBox4.Value, 0) '退勤時刻
        .Cells(tgtRow, 4).Value = TimeSerial(Me.TextBox5.Value, Me.TextBox6.Value, 0) '休憩開始時刻
        .Cells(tgtRow, 5).Value = TimeSerial(Me.TextBox7.Value, Me.TextBox8.Value, 0) '休憩終了時刻
    End With

  
Next
Next r
    MsgBox "登録しました"
End Sub

試したこと

予め休日の日は数値を入れておいてみたのですが、一番最終行や途中の行の数値が上書きされてしまい
上から順番に空白のセルに入りませんでした。

補足情報（FW/ツールのバージョンなど）

・月によっての処理分けが出来ていません。
For Each SH In ActiveWorkbook.Worksheets
でアクティブ中のシートが対象になるようになっています。

・出勤と退勤は処理ボタンを分けています
(出勤打刻して一度ファイルを閉じて退勤時にまた開くことを想定しているため。
退勤打刻の際には年月日は選びません)

Comments

[tatsu99]

シート名は、具体的にはどうなっていますか。"10月","11月","12月"ですか。
出勤時刻登録時は、出勤年月日も入力されるので、その日付から、シートと行番号を決定できます。
退勤時刻登録時は、出勤年月日は、フォーム上のコンボボックスにないのでしょうか。
もし、あるなら、同様に、それを使い、その日付から、シートと行番号を決定できます。

[milk1218]

アドバイスありがとうございます・・！

シート名は「10」「11」「12」となっておりまして
登録時のフォームは分かりづらいので画像を補足しました。
退勤時には年月日は登録しない仕様になっています。

[tatsu99]

補足ありがとうございました。
念のため確認ですが、月が決まれば、シートは決まります。
日が決まれば、行も決まると考えて良いですか。
１日なら2行目、３０日なら３１行目、31日なら３2行目です。
退勤時、年月日は登録しませんが、フォーム上にも、年月日は表示されないのでしょうか。
もし、表示されるなら、年月日の登録はしませんが、それを使用して、シート名と行番号を決めることは可能です。
もし、退勤時、年月日がフォーム上に表示されないなら、出勤時刻のみが登録されているシートを順に探して、そのシートの該当行を、退勤時刻登録の行とするしかないです。

[milk1218]

日が決まれば行も決まります・・！仰る通り、１日なら2行目、３０日なら３１行目、31日なら３2行目です。例えば２０２１年10/1という日付だけ登録して出退勤時刻を打たずに一旦閉じて、またフォームを起動した際に10/2で打刻したら次の行に入ります・・！
ただ、月を判別することは出来ないので、アクティブ中のシートが32まで埋まったら自動的に隣のシートに移るという仕様です。
退勤時、年月日がフォーム上に表示されないので後者のやり方を試そうと思います！
ありがとうございます・・！

[jinoji]

退勤時の処理がその当日に起動されるのなら、年月日は Date なり Now なりで分かるんではないの？

Answer 1

追加で画像添付しました

Answer 2

マクロ独学の者ですがコード書いてみました
他人様に見せる様な構文でもなく、あくまでも、参考にしてください
それから「年月日」と「時間」の入力は　TextBoxに統一しました
入力個数もカットしました
UserFormモジュール

Private Sub CommandButton1_Click()
'登録ボタン
Call 登録Button1
End Sub
Private Sub CommandButton2_Click()
'検索ボタン
 Call 検索Button2
End Sub
Private Sub CommandButton3_Click()
'修正ボタン
  Call 修正Button3
End Sub
Private Sub CommandButton4_Click()
'終了ボタン
Unload Me
End Sub
'ここから標準モジュールーーーーーーーーー

Sub 登録Button1()
'登録ボタン
Call 宝探し     '年月日の場所探す
Call 新規登録
   Call Macro1　'日付並べ替え
     Call Fomeクリア
   Sheets("フォーム").Select
End Sub
Sub 検索Button2()
'検索ボタン
 Call 宝探し       '年月日の場所探す
  Call データ呼び出し
'  Sheets("フォーム").Select
End Sub
Sub 修正Button3()
'修正ボタン
      Call データ戻し
        Call Fomeクリア
      Sheets("フォーム").Select
End Sub
Sub Fomeクリア()
          UserForm1.TextBox1.Text = ""
            UserForm1.TextBox2.Text = ""
            UserForm1.TextBox3.Text = ""
            UserForm1.TextBox4.Text = ""
            UserForm1.TextBox5.Text = ""
End Sub
’----------------------------------------
Option Explicit
Dim mm As Long, i As Long, n As Long '
Public ii As Long    'セル行番号
Dim ymd As Date '年月日
Dim Stmm As String, yb As String
Public sheet名   As String
Sub kidou()
UserForm1.Show
End Sub
Sub 宝探し()
'ymd=年月日
ymd = UserForm1.TextBox1.Text
'曜日取得
yb = WeekdayName(Weekday(ymd), True)
'mm=月
mm = Month(ymd)
      'このブック内のシート枚数
'      枚数 = Sheets.Count
      'For Nextでシート名取得
      For i = 2 To Sheets.Count
            sheet名 = Worksheets(i).Name
            '文字列に変換　Str(mm)
            'Trim(文字列）文字列の前後の空白を削除
            Stmm = Trim(Str(mm))  '
            If Stmm = sheet名 Then 'シート名の照合
'                  MsgBox "該当するシート名が見つかりました"
                 Exit Sub
            End If
      Next i
End Sub
Sub 新規登録()
      Sheets(sheet名).Select
'      A列最終行取得 プラス1行(空白行)
      n = Cells(Rows.Count, "A").End(xlUp).Row + 1
            Cells(n, 1).Select
            Cells(n, 1) = UserForm1.TextBox1.Text
            Cells(n, 3) = UserForm1.TextBox2.Text
            Cells(n, 4) = UserForm1.TextBox3.Text
            Cells(n, 5) = UserForm1.TextBox4.Text
            Cells(n, 6) = UserForm1.TextBox5.Text
            Cells(n, 2) = yb
             MsgBox "転記しました"
             'ここで日付順に並び替えします
             Call Macro1  'マクロの記録
             'フォーム画面に戻る
             Sheets("フォーム").Select
             Exit Sub
End Sub
Sub データ呼び出し()
'入力済データ呼び出し
      Sheets(sheet名).Select
      'A列最終行取得
      n = Cells(Rows.Count, "A").End(xlUp).Row
      For ii = 2 To n
            'A列の２行目からTextBox1.の年月日と同じ年月日を照合
            If ymd = Cells(ii, 1).Value Then
            Cells(ii, 1).Select
'            UserForm1.TextBox1.Text = Cells(ii, 1)
            UserForm1.TextBox2.Text = Cells(ii, 3).Text
            UserForm1.TextBox3.Text = Cells(ii, 4).Text
            UserForm1.TextBox4.Text = Cells(ii, 5).Text
            UserForm1.TextBox5.Text = Cells(ii, 6).Text
            Cells(ii, 1).Select
             MsgBox "呼び出ししました"
             Exit Sub
            End If
      Next ii
End Sub
Sub データ戻し()
           Cells(ii, 1).Select
             Cells(ii, 2) = yb
             Cells(ii, 1) = UserForm1.TextBox1.Text
            Cells(ii, 3) = UserForm1.TextBox2.Text
            Cells(ii, 4) = UserForm1.TextBox3.Text
            Cells(ii, 5) = UserForm1.TextBox4.Text
            Cells(ii, 6) = UserForm1.TextBox5.Text
             MsgBox "転記しました"
End Sub
’ーーーーーーーーーーーーーーーーーーーーーーーーー
Sub Macro1()
'マクロの記録コピー
Worksheets(sheet名).Select
    Range("A2:H33").Select
    ActiveWorkbook.Worksheets(sheet名).Sort.SortFields.Clear
    ActiveWorkbook.Worksheets(sheet名).Sort.SortFields.Add2 Key:=Range("A2:A33"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets(sheet名).Sort
        .SetRange Range("A2:H33")
'        .Header = xlGuess
'        .MatchCase = False
'        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
End Sub

Comments

[milk1218]

ありがとうございます・・！！
こちらの方が入力項目も少なく、使いやすいと思いました・・・！
参考にさせていただきます！！！！

Answer 3

Sub 出勤時間登録()
    Dim 日付, 出勤時刻
    日付 = DateSerial(Me.cb1.Value, Me.cb2.Value, Me.cb3.Value)
    出勤時刻 = TimeSerial(Me.TextBox1.Value, Me.TextBox2.Value, 0)
    
    Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name = Month(日付) Then Exit For
    Next
    
    ws.Columns(1).Find(日付, , xlValues).Offset(, 1).Value = 出勤時刻

End Sub

Sub 退勤時間登録()
    Dim 日付, 退勤時刻, 休憩開始時刻, 休憩終了時刻
    日付 = Date
    退勤時刻 = TimeSerial(Me.TextBox3.Value, Me.TextBox4.Value, 0)
    休憩開始時刻 = TimeSerial(Me.TextBox5.Value, Me.TextBox6.Value, 0)
    休憩終了時刻 = TimeSerial(Me.TextBox7.Value, Me.TextBox8.Value, 0)
    
    Dim ws As Worksheet
    For Each ws In Worksheets
        If ws.Name = Month(日付) Then Exit For
    Next
    
    ws.Columns(1).Find(日付, , xlValues).Offset(, 2).Resize(, 3).Value = Array(退勤時刻, 休憩開始時刻, 休憩終了時刻)

End Sub

Comments

[milk1218]

ありがとうございます・・・！！
参考にさせていただきます・・・！

Answer 4

他にもやり方があれば教えていただけますでしょうか。

データのシート（Sheet1）と整形するシート（1,2,3,4,,12）に分けるとコードも構造も簡単になります。
最初にデータを集積させる表をSheet1に作ります。
A列に年月日　A2に初期値2021/1/1を、A3に式=A2+1をセット
B2に数式=TEXT(A2,"aaaa")をセット、すると曜日が表示されます。
両方とも20年分、30年分でも好きなだけ下へ数式をコピーします。
条件付き書式で、土曜日は青色、日曜日は赤色にするといいかもしれません。

次にシート名「1」を作り
A1を年を入力することにして、B1に数式=RIGHT(CELL("filename",A1),LEN(CELL("filename",A1))-FIND("]",CELL("filename",A1)))
をセットすると1が表示されます。
A3に=DATE(A$1,B$1,1)
A4に＝A3+1
A4を33行まで数式をコピー
B3に数式=INDEX(Sheet1!B$2:B$10000,MATCH(A3,Sheet1!$A$2:$A$10000,0),1)を入れ
b3をアクティブにしてb3:H33を選択・数式貼り付け
とすることで、Sheet1の2021年の1月分がコピーができます。
画像では10000が1126になっています。

シート名「1」をコピーしてシート名「2」を作り
A1を='１'!A1とします。
2月は29日までだから32・33行の数式を削除、閏年に対処するため
A31に=IF(MONTH(A30+1)=B1,A30+1,"")
B31に=IF(A31="","",INDEX(Sheet1!B$2:B$10000,MATCH($A31,Sheet1!$A$2:$A$10000,0),1))として、B31をアクティブにしてB31:H31を選択・数式貼り付け
とすることで、Sheet1の2021年の2月分がコピーができます。
以下12まで月に応じたシートを作成します。
sheet1の入力・修正だけで済み、年の指定もSheet1!A1の1カ所で済みます。

入力フォームは、Sheet1の目的とする日付のセルをクリックして開くこととし、
Sheet1のコードは以下の流れにがいいと思います。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim UF As Object

    With Target
        If .Count = 1 And .Column = 1 And _
           .Row > 1 Then
        
            Cancel = True
        
            myUF.Show
            For Each UF In UserForms
                ’ハイドにするとここで処理されます。閉じていれば素通りです。
                If TypeOf UF Is myUF Then
                    With ActiveCell
                        ’フォームのデータを計算してシートに書き込みます。
                        Application.ScreenUpdating = False
                        .Offset(0, 2).Value = (UF("myCont1").Value / 24) + (UF("myCont2").Value / 24 / 60)
                        .Offset(0, 3).Value = (UF("myCont3").Value / 24) + (UF("myCont4").Value / 24 / 60)
                        .Offset(0, 4).Value = (UF("myCont5").Value / 24) + (UF("myCont6").Value / 24 / 60)
                        .Offset(0, 5).Value = (UF("myCont7").Value / 24) + (UF("myCont8").Value / 24 / 60)
                        .Offset(0, 6).Value = .Offset(0, 3).Value - .Offset(0, 2).Value - (.Offset(0, 5).Value - .Offset(0, 4).Value)
                        .Offset(0, 7).Value = UF("myCont9").Value
                        Application.ScreenUpdating = True
                    End With
                    Unload UF
                End If
            Next UF

        End If
    End With
      
End Sub

Sheet1がアクティブになった時、現在日にスクロールして現在日をアクティブにします。

Private Sub Worksheet_Activate()
    Dim goRow As Long

    goRow = CLng(DateSerial(Year(Date), Month(Date), Day(Date)))

    goRow = Application.Match(goRow, Worksheets("Sheet1").Columns(1), 0)

    Application.Goto Worksheets("Sheet1").Cells(goRow - 10, 1), True
    Worksheets("Sheet1").Cells(goRow, 1).Activate

End Sub

フォームのコードです。オブジェクト名はmyUFとし、ラベルLabel1,Label2を配置して、Label1に日付、Label2に曜日
コンボ・テキストボックスmycont1～mycont9を配置して、mycont1に出勤の時、mycont2に出勤の分、略
mycont9に備考をセットします。登録・修正は、フォームをハイドにしてSheet1で行います。

Private Sub UserForm_Initialize()

    With ActiveCell
        Me.Label1.Caption = .Offset(0, 0).Value
        Me.Label2.Caption = .Offset(0, 1).Value
        Me("mycont1").Value = Format(.Offset(0, 2).Value, "hh")
        Me("mycont2").Value = Format(.Offset(0, 2).Value, "nn")
        Me("mycont3").Value = Format(.Offset(0, 3).Value, "hh")
        Me("mycont4").Value = Format(.Offset(0, 3).Value, "nn")
        Me("mycont5").Value = Format(.Offset(0, 4).Value, "hh")
        Me("mycont6").Value = Format(.Offset(0, 4).Value, "nn")
        Me("mycont7").Value = Format(.Offset(0, 5).Value, "hh")
        Me("mycont8").Value = Format(.Offset(0, 5).Value, "nn")
        Me("mycont9").Value = .Offset(0, 7).Value
    End With

End Sub

Private Sub 登録_Click()

    Me.Hide

End Sub

Private Sub 閉じる_Click()

    Unload Me

End Sub

Comments

[milk1218]

シートを二つ用意して組むやり方も知りたかったので助かりました・・！
ありがとうございます・・・！！

ご丁寧にご説明いただきありがとうございました・・・！！

Answer 5

回答ではありませんが　３年前に個人で作ったものですが、会社に提出した
勤務内容と賃金計算が間違いないか　マクロで組んだものです。
画像６枚になりますが参考まで。
ユーザーフォームは使っていまませんエクセルシートで入力処理とデーダ扱い
です
カレンダーも作成しています
!明](c10baf2bedee5b7a781282d7466f26bb.png)

Comments

[milk1218]

分かりやすく画像に説明までつけていただいてありがとうございます・・！！
マクロでの組み方も知らなかったのでとても勉強になりました・・！！
今後使う場面がありそうなので参考にさせていただきます！

Answer 6

出勤時は、月からシート名を決定し、日から行番号を決定しています。
退勤時は、シー名を全て検索し、シート名が1～12の何れかで、かつ、集金時刻があり、退勤時刻が空白の
行を探しています。
簡単な試験しか行っていません。不具合、不明点があれば補足してください。

Private Sub cb_touroku_Click()
    Dim tgtRow As Long
    Dim ws As Worksheet
    Dim wsname As String
    wsname = Me.CB2.Value
    Set ws = Worksheets(wsname)
    tgtRow = Me.CB3.Value + 1

    ws.Cells(tgtRow, 1).Value = DateSerial(Me.CB1.Value, Me.CB2.Value, Me.CB3.Value)    '年月日
    ws.Cells(tgtRow, 2).Value = TimeSerial(Me.TextBox1.Value, Me.TextBox2.Value, 0)    '出勤時刻

    MsgBox "登録しました"
End Sub

Private Sub cb_touroku2_Click()
    Dim tgtRow As Long
    Dim SH As Worksheet
    Dim flag As Boolean
    flag = False
    For Each SH In ActiveWorkbook.Worksheets
        If IsNumeric(SH.name) = True Then
            If CLng(SH.name) > 0 And CLng(SH.name) < 13 Then
                tgtRow = SH.Cells(Rows.count, "B").End(xlUp).Row    '当該sheetＢ列の最大行取得
                If tgtRow > 1 And SH.Cells(tgtRow, "B").Value <> "" And SH.Cells(tgtRow, "C").Value = "" Then
                    SH.Cells(tgtRow, 3).Value = TimeSerial(Me.TextBox3.Value, Me.TextBox4.Value, 0)    '退勤時刻
                    SH.Cells(tgtRow, 4).Value = TimeSerial(Me.TextBox5.Value, Me.TextBox6.Value, 0)    '休憩開始時刻
                    SH.Cells(tgtRow, 5).Value = TimeSerial(Me.TextBox7.Value, Me.TextBox8.Value, 0)    '休憩終了時刻
                    flag = True
                    Exit For
                End If
            End If
        End If
    Next
    If flag = True Then
        MsgBox "登録しました"
    Else
        MsgBox "登録失敗"
    End If
End Sub

Comments

[tatsu99]

過去にさかのぼって、時刻を登録すると失敗します。
例
①10月18日の出勤時刻を登録
②10月18日の退勤時刻を登録
10月15日の登録がもれていたことに気づき
③1０月15日の出勤時刻を登録（これはＯＫ）
④1０月15日の退勤時刻を登録（ここで失敗する）
このようなケースがあるなら、その旨返信ください。

[milk1218]

ありがとうございます！！！！
おかげさまで理想の形のものになりました！！
本当に助かりました・・・！！！

[milk1218]

仰る通り、過去にさかのぼって時刻を登録すると失敗しますが
休日を避けて登録することは出来るようになったため、助かりました・・！！
ありがとうございます・・・！！

Answer 7

A列に日付があるのですから、曜日を判定してはいかがでしょうか？

以下、ご参考まで

https://www.moug.net/tech/exvba/0130008.html

Comments

[milk1218]

ありがとうございます・・！！
曜日名で指定できるんですね・・・！