VBA既存シートからリスト形式の作成

質問

Excel VBAの質問です
(Office2021を使用）

給与計算のための労働時間計算を、事務スタッフがクラウド上の計算サービスに、スタッフ15名分ほどを、１人１人手入力をし、入力間違いが起こっていました

クラウドのサービス会社に問い合わせてみたところ、指定の列をもつCSV形式にして、一括インポートができることがわかりました

で、まず各人のタイムカードの時刻から労働時間を自動計算するシートをわたしがつくり、全人の労働時間が出たので、あとは時給を掛けるだけでその月の支払い総額がわかるようにしました

つまり全員の労働時間のシートを、同じ形にしました

で、あまり詳しくないですが、マクロ（自動記録）で、各シートにある氏名と時間列のセル（具体的にはB2 G41 H41 J41 K41）を、画像のようなリストの形に流し込みたいと思いました

しかし2行目（スタッフNo.0001番）は自動で入ったものの、3行目（スタッフNo.0002）以降の追加のコードがわかりません

スタッフは月によって変動しだいたい13～MAXでも20名いるので、シート数は最大20はあります

【質問orお願い】
・その月につくったスタッフ人数分のシートの総数を確認し、各労働時間（各シートのB2 G41 H41 J41 K41）を、画像のような列に入れ込むコードはどう書いたらよいでしょうか？

アイデアをいただきたい、または親切な方いましたらコード書いていただけると助かります

【回答上のご注意】
・回答は解答（答え）を求めての投稿です
・昭和的な「あとは自分で考えろ」的なものは求めていません
（登山の途中でいなくなる登山ガイドのようなものです）
・不明点あれば追加情報をお伝えします

動作の結果責任は問いませんのでよろしくお願いします

回答No.4

kkkkkm

> （問題解答＋正誤ジャッジサイト）をご存知でしたらご教示いただけると幸いです

このあたりは私自身使う事が無いのでちょっとわからないです。

コードに関してシートの新規作成などの仕様もこちらでは細かいことが分かりませんから、基本的な変更案を出すことはできないと思いますが現状のコードで実際にやりたいことが実現できないなどの変更に関してお手伝いすることくらいはできると思います。

お礼

ありがとうございます
独習サイト探しは、別質問たててみます

回答No.3

kkkkkm

CSV出力するのでしたらそこまでVBAでやってしまえばいいのではないでしょうか

回答No.1のコードの最後にある
Set WsM = Nothing
の前に以下を追加すれば最初に指定したシートのデータをCSV出力します。

Dim NewCsvFile As String

NewCsvFile = ThisWorkbook.Path & "\test.csv"

WsM.Copy

ActiveWorkbook.SaveAs Filename:=NewCsvFile, FileFormat:=xlCSV, Local:=True
ActiveWorkbook.Close SaveChanges:=False

お礼

ありがとうございます

CSVは最終的に書き出すので、参考にして別のモジュールにしようと思います
自己完結する場合は一連を全部出力までしたいのですが、経営者（女性）は余計なものを見せると混乱するので、最低限の列（項目）を見せて承認とっています

ところでご存知でしたら教えていただきたいのですが、Excel VBAを自習できる（練習問題のある独習）サイトはご存知ですか？
練習問題に対して、合否が出るサイトを探していあｍす

PythonとJavaの資格はもっていて、Paiza（課金しています）で忘れないよう練習問題を説いているのですが、Excel VBAはないようです。

Excel VBA自体はポピュラーだと思うのですが、独学に特化した学習サイト（問題解答＋正誤ジャッジサイト）をご存知でしたらご教示いただけると幸いです

回答No.2

kkkkkm

既存のシート(質問の画像のシート)に転記するのだと思ってましたが、新しいシートを作ってそこに転記するのですか？

お礼

実はインポート用のcsv列はもっとあるのですが、経営者が知りたいのは時間（と支払う給与）なので、事前確認用に、計算に漏れたスタッフ（通常月中で入社した人）の分のを生成したいので、新規のSheetN+1がいいかなと思いました

回答No.1

kkkkkm

どのシートがどの人のシートになるのか不明ですので左から2番目のシートのデータを一番上にその後参照するシートが右へ移るたびに下にデータを追記していきます。質問の画像のシートは一番左にあるものとしています。

A列、C列は指定が無いので何もしません。
セルの書式はあらかじめ指定しておいてください。

以下のコードを実行してここはこうしたいというものがあれば追記してください。

Sub Test()
Dim WsCnt As Long
Dim LastRow As Long
Dim WsM As Worksheet

Set WsM = Sheets("Sheet1") '質問の画像のシートを指定してください。

With WsM
'左から2番目のシートから右方向へ移動して上から順にデータを転記
For WsCnt = 2 To Sheets.Count
LastRow = .Cells(Rows.Count, "B").End(xlUp).Row + 1
.Cells(LastRow, "B").Value = Sheets(WsCnt).Range("B2").Value
.Cells(LastRow, "D").Value = Sheets(WsCnt).Range("G41").Value
.Cells(LastRow, "F").Value = Sheets(WsCnt).Range("H41").Value
.Cells(LastRow, "H").Value = Sheets(WsCnt).Range("J41").Value
.Cells(LastRow, "J").Value = Sheets(WsCnt).Range("K41").Value
Next

End With

Set WsM = Nothing

End Sub

お礼

ありがとうございます
試してみます

実はAIと相談しながらつくっていて、Sheet1など既存のシート名とバッティングするので、Sheet N + 1　みたいなのを書かせたら

' 新しいシート名を生成
sheetNumber = 1
Do
newSheetName = "Sheet" & sheetNumber
If Not SheetExists(newSheetName) Then
Exit Do
End If
sheetNumber = sheetNumber + 1
Loop

' 新しいシートを作成
Set newWs = ThisWorkbook.Worksheets.Add
newWs.Name = newSheetName

を書いてきました

| Set WsM = Sheets("Sheet1") '質問の画像のシートを指定してください。

こういう手もあるんですね。
ちなみにAIのも動いたみたいなので、補足欄に（自分が見返すために）コード入れておこうと思います

補足

Sub CopyValuesToNewSheet()
' 労働時間をリストにする／アクティブシートの右側だけ
Dim ws As Worksheet
Dim newWs As Worksheet
Dim rowCounter As Long
Dim startIndex As Integer
Dim i As Integer
Dim newSheetName As String
Dim sheetNumber As Integer

' アクティブシートのインデックスを取得
startIndex = ActiveSheet.Index

' 新しいシート名を生成
sheetNumber = 1
Do
newSheetName = "Sheet" & sheetNumber
If Not SheetExists(newSheetName) Then
Exit Do
End If
sheetNumber = sheetNumber + 1
Loop

' 新しいシートを作成
Set newWs = ThisWorkbook.Worksheets.Add
newWs.Name = newSheetName

rowCounter = 2 ' 新しいシートの開始行

' アクティブシートから右側のシートをループ
For i = startIndex To ThisWorkbook.Worksheets.Count
Set ws = ThisWorkbook.Worksheets(i)

' 新しく作成したシートをスキップ
If ws.Name <> newSheetName Then
' 指定されたセルの値を新しいシートにコピー
newWs.Cells(rowCounter, 2).Value = ws.Range("B2").Value
newWs.Cells(rowCounter, 4).Value = ws.Range("G41").Value
newWs.Cells(rowCounter, 6).Value = ws.Range("H41").Value
newWs.Cells(rowCounter, 8).Value = ws.Range("J41").Value
newWs.Cells(rowCounter, 10).Value = ws.Range("K41").Value

rowCounter = rowCounter + 1 ' 次の行に移動
End If
Next i

' 列の幅を自動調整
newWs.Columns("A:J").AutoFit

MsgBox "処理が完了しました。新しいシート名: " & newSheetName, vbInformation
End Sub

' シートが存在するかチェックする関数
Function SheetExists(sheetName As String) As Boolean
Dim ws As Worksheet

On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
On Error GoTo 0

SheetExists = Not ws Is Nothing
End Function