年月日を空白に置換後、書式設定を[h]:m

質問

添付しましたデータのイメージ画面の向左側のExcelデータの、
F列3行目以降とG列3行目以降の時刻のデータは、見かけは時分表示になっていますが、
例えば、G列$4のセルの中は『24:00』で表示されていますが、
数式バーの赤枠の値は、『1900/1/1　0:00:00』と表示されています。

Ｆ列$14のセルの中は『9:49』で表示されていますが、
数式バーの赤枠の値は、『2024/5/15 09:49:23』と表示されています。
F列3行目以降とG列3行目以降の時刻のデータは、
このように、F列3行目以降とG列3行目以降の時刻のデータは、
所々に、上記のようなデータが入っています。

今回マクロでやりたい事は以下の通りになります。
下記条件を満たすマクロがお分かりでしたら、ご教示頂けましたら大変助かります。
①マクロ起動後、修正するファイルを選択できるようにする。
②選択したファイルは、データ修正前に、ファイル名の頭に『bak-』を付けたファイル名でそのホルダー内へ保存させる。
③選択したファイルのシートのデータに直接修正を加える。
④修正対象列は、Ｆ列とG列の3行目以降のデータとする。
⑤『2024/5/15 09:49:23』などと表示されているデータが入っているセルのみをピンク塗りつぶしにする。
⑥F列の時刻データは日を越したデータは入っていないので、書式設定は『h:mm』の設定にする。
⑦F列の時刻データは、『24:00』のように日を跨いだデータが入っている事がある為、書式設定は『[h]:mm』の設定にする。

※添付しましたデータのイメージ画面の向左側のExcelデータの、
　F列3行目以降とG列3行目以降の時刻のデータは、見かけは時分表示になっていますが、
　例えば、G列$4のセルの中は『24:00』で表示されていますが、
　数式バーの赤枠の値は、『1900/1/1　0:00:00』と表示されています。

※数式バー上の表示が、『2024/5/15 09:49:23』などと表示されている
　データだけについて、『2024/5/15 09:49:23』→『09:49:23』へ置換をする。
　但し、『1900/1/1　0:00:00』データの場合は、置換せずそのままとする。
　数式バーの中が時分のみで表示されているセルのデータは置換せずそのままとする。
　ピンク塗りつぶしも、『2024/5/15 09:49:23』などと表示されているセルのみ塗りつぶす。

下記のコードでは、『2024/5/15 09:49:23』などのデータは認識出来ませんでした。
For Each cell In ws.Range("F3:F" & lastRow)
If cell.Value Like "20*/*/* *:*:*" Then
cell.Value = Replace(cell.Value, Left(cell.Value, InStr(cell.Value, " ")), "")
cell.NumberFormat = "h:mm"
End If
Next cell

For Each cell In ws.Range("G3:G" & lastRow)
If cell.Value Like "20*/*/* *:*:*" Then
cell.Value = Replace(cell.Value, Left(cell.Value, InStr(cell.Value, " ")), "")
cell.NumberFormat = "[h]:mm"
End If
Next cell

下記コードは、『2024/5/15 09:49:23』などと表示されているセルを認識してくれましたが、
『1900/1/1　0:00:00』も『0:00:00』へ置換されてしまいました。
If cell.Value Like "*/*/* *:*:*" Then

色々と試して見たのですが、セルのピンク塗りつぶしも上手くいきませんでした。

下記へデータを記載させて頂きました。
装置 部署 利用日 開始時間 終了時間
共用部門装置ID 装置名 プラットフォーム ユニット
MM0152 工作機械群 PF 材料加工 2024/5/1 10:00 24:00:00
MM0152 工作機械群 PF 材料加工 2024/5/2 10:00 24:00:00
MM0152 工作機械群 PF 材料加工 2024/5/7 10:00 24:00:00
MM0152 工作機械群 PF 材料加工 2024/5/10 10:00 13:00
MM0150 硝子工作 PF 材料加工 2024/5/9 10:30 11:00
MM0150 硝子工作 PF 材料加工 2024/5/10 10:00 10:30
MM0150 硝子工作 PF 材料加工 2024/5/13 10:00 10:30
MM0153 試料作製 PF 材料加工 2024/5/2 9:34 11:40
MM0153 試料作製 PF 材料加工 2024/5/2 11:22 16:00
MM0153 試料作製 PF 材料加工 2024/5/2 10:13 12:00
MM0151 機械工作室 工作機械 PF 材料加工 2024/5/15 11:11 11:20
MM0151 機械工作室 工作機械 PF 材料加工 2024/5/15 9:49 11:50
MM0151 機械工作室 工作機械 PF 材料加工 2024/5/15 9:36 15:16

回答No.7

kkkkkm · ベストアンサー

> 今回は、時刻データ扱いの難しさを実感しました。

日付とか時刻は私も面倒だと思ってます。Findで日付を検索する場合も表示形式によっては見つけられないとかもあります。

> F列3行目～最終行の書式の設定は、h:mm
> G列3行目～最終行の書式の設定は、[h]:mmにしなければなりませんでした。

年月日を削除したセルだけではなく各列の3行目から最終行まででしたら
ループ内の
cell.NumberFormat = "[h]:mm"
を削除して

ループの外

Next cell

の後で

ws.Range("F3:F" & lastRow).NumberFormat = "h:mm"
ws.Range("G3:G" & lastRow).NumberFormat = "[h]:mm"

としてみてください。

年月日を削除したセルだけでしたらループ内の

cell.NumberFormat = "[h]:mm"

を

If cell.Column = Columns("F").Column Then
cell.NumberFormat = "h:mm"
Else
cell.NumberFormat = "[h]:mm"
End If

に変更してみてください。

お礼

有難うございました。 心より感謝申し上げます。

Powered by GRATICA

補足

早速、ご教示頂きまして有難うございました。
自分が気付けない事まで細やかにご教示下さり、本当に感謝しております。
再就職した3年前より、kkkkkm様始め、沢山の方から優れたご教示を頂いたお陰で、仕事は何とか乗り切っております。
早速、ご教示頂いたコードへ修正しマクロの正常性を確認出来ました。
こんなに簡便なコードで出来てしまう事に改めて感動しました。

回答No.6

kkkkkm

> 下記の通りにマクロを修正し、『2024/5/15 09:49:23』などの年月日が入っているセルをピンク塗りつぶしにする事が出来ました。
> 又、『2024/5/15 09:49:23』などの年月日も削除する事が出来ました。

回答した部分だけがうまくいってなくて、後はできていると思っていたのですが想像通りでした。
希望の動作ができて良かったです。

あと、コードで塗りつぶしと年月日削除と2回ブックを開いて操作しているみたいですが、一度でやってしまうとどうなのでしょう。

余計なお世話かもしれませんが一応参考までに G列F列隣なのでループのコードは一度で済ましています。

Sub ModifyDataInSelectedFile()
Dim fd As FileDialog
Dim selectedFile As String
Dim backupFileA As String
Dim backupFile As String
Dim ws As Worksheet
Dim cell As Range
Dim lastRow As Long
Dim wb As Workbook

' ファイルダイアログを開いてファイルを選択
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.Title = "データ修正するファイルを選択してください"
fd.Filters.Clear
fd.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
If fd.Show = -1 Then
selectedFile = fd.SelectedItems(1)
Else
MsgBox "ファイルが選択されていません。", vbExclamation
Exit Sub
End If

' バックアップファイルの作成
backupFileA = Mid(selectedFile, InStrRev(selectedFile, "\") + 1)
backupFile = "bak-" & backupFileA

FileCopy selectedFile, backupFile

' 選択したファイルを開く
Set wb = Workbooks.Open(selectedFile, UpdateLinks:=False)
Set ws = wb.Sheets("カテゴリーログ")

' データの修正
lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row

For Each cell In ws.Range("G3:F" & lastRow)
If Year(cell.Value) Like "20*" Then
cell.Value = Format(Hour(cell.Value) & ":" & Minute(cell.Value) & ":" & Second(cell.Value))
cell.NumberFormat = "[h]:mm"
cell.Interior.Color = RGB(255, 182, 193) ' ピンク色に塗りつぶし
End If
Next cell

' 修正結果を上書き保存
wb.Save
wb.Close

' メッセージ表示
MsgBox "データ修正が完了しました。", vbInformation
End Sub

補足

理想のコードのご教示ありがとうございました。
マクロを作り始めた時は、塗りつぶしと時間の修正は1つのループの中で実施するようにしておりました。
しかし、時間の修正はご察しの通り、途中までは出来ていたのですが、色塗りつぶしが全く出来なかったので、切り分けの為、別々に実施するようにしていました。
今回は、時刻データ扱いの難しさを実感しました。

すみません、今、気づいたのですが、
F列3行目～最終行の書式の設定は、h:mm
G列3行目～最終行の書式の設定は、[h]:mmにしなければなりませんでした。
大変恐縮ですが、上記へ変更したコードをご教示頂けましたら大変助かります。

回答No.5

SI299792

ファイル選択～bak-の作成迄します。
Option Explicit
'
Sub Macro1()
　　Dim File As Variant
　　Dim Cell As Range
'
　　File = Application.GetOpenFilename _
　　　　("Microsoft Excelブック,*.xls?", Title:="Ｆ～Ｇ列の日付をカット")
'
　　If File = False Then
　　　　End
　　End If
　　Application.ScreenUpdating = False
　　Set File = Workbooks.Open(File, False)
　　Set Cell = Cells(Rows.Count, "G").End(xlUp)
'
　　For Each Cell In Range("F3", Cell)
'
　　　　If Cell > 31 Then
　　　　　　Cell = Cell - Int(Cell)
　　　　End If
　　Next Cell
　　[F:G].NumberFormatLocal = "[h]:mm"
　　ActiveWorkbook.SaveAs _
　　　　ActiveWorkbook.Path & "\" & "bak-" & ActiveWorkbook.Name
　　ActiveWorkbook.Close
　　MsgBox "処理終了"
End Sub
\ はVBE 上で半角￥になります。

お礼

ご教示ありがとうございました。 マクロでやりたかった事の説明が下手で申し訳ありませんでした。

Powered by GRATICA

回答No.4

SI299792

Ｆ～Ｇ列が対象ですか？
基準を決めてそれ以下なら日付を消せばいいです。
31日を基準にしました。
Option Explicit
'
Sub Macro1()
　　Dim Cell As Range
'
　　Set Cell = Cells(Rows.Count, "G").End(xlUp)
'
　　For Each Cell In Range("F4", Cell)
'
　　　　If Cell > 31 Then
　　　　　　Cell = Cell - Int(Cell)
　　　　End If
　　Next Cell
　　[F:G].NumberFormatLocal = "[h]:mm"
End Sub

回答No.3

kkkkkm

> For Each cell In ws.Range("F3:F" & lastRow)
> If cell.Value Like "20*/*/* *:*:*" Then
> cell.Value = Replace(cell.Value, Left(cell.Value, InStr(cell.Value, " ")), "")
> cell.NumberFormat = "h:mm"
> End If
> Next cell

の部分だけですが

For Each cell In ws.Range("F3:F" & lastrow)
If Year(cell.Value) Like "20*" Then
cell.Value = Format(Hour(cell.Value) & ":" & Minute(cell.Value) & ":" & Second(cell.Value))
cell.NumberFormat = "h:mm"
End If
Next cell

で試してみてください。

お礼

何時も、優れたご教示を頂きまして心より感謝です。このマクロは完成するまでに２カ月程かかりました。色々コードを変えたりしましたが全く解決出来ずにいました。ご教示頂き一挙に解決出来ました。

Powered by GRATICA

補足

下記の通りにマクロを修正し、『2024/5/15 09:49:23』などの年月日が入っているセルをピンク塗りつぶしにする事が出来ました。
又、『2024/5/15 09:49:23』などの年月日も削除する事が出来ました。ありがとうございました。
Sub ModifyDataInSelectedFile()
Dim fd As fileDialog
Dim selectedFile As String
Dim backupFileA As String
Dim backupFile As String
Dim ws As Worksheet
Dim cell As Range
Dim lastRow As Long
Dim wb As Workbook

' ファイルダイアログを開いてファイルを選択
Set fd = Application.fileDialog(msoFileDialogFilePicker)
fd.Title = "データ修正するファイルを選択してください"
fd.Filters.Clear
fd.Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsm"
If fd.Show = -1 Then
selectedFile = fd.SelectedItems(1)
Else
MsgBox "ファイルが選択されていません。", vbExclamation
Exit Sub
End If

' バックアップファイルの作成
backupFileA = Mid(selectedFile, InStrRev(selectedFile, "\") + 1)
backupFile = "bak-" & backupFileA

FileCopy selectedFile, backupFile

' 選択したファイルを開く
Set wb = Workbooks.Open(selectedFile, UpdateLinks:=False)
Set ws = wb.Sheets("カテゴリーログ")

' データの修正
lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row

' F列とG列のセルをチェックしてピンク塗りつぶし
For Each cell In ws.Range("F3:F" & lastRow)
If Year(cell.Value) Like "20*" Then
cell.Interior.Color = RGB(255, 182, 193) ' ピンク色に塗りつぶし
End If
Next cell

For Each cell In ws.Range("G3:G" & lastRow)
If Year(cell.Value) Like "20*" Then
cell.Interior.Color = RGB(255, 182, 193) ' ピンク色に塗りつぶし
End If
Next cell

' 上書き保存してファイルを閉じる
wb.Save
wb.Close

' 再度ファイルを開いて追加条件②の処理を実行
Set wb = Workbooks.Open(selectedFile, UpdateLinks:=False)
Set ws = wb.Sheets("カテゴリーログ")

' F列とG列の修正: 年月日を削除して時間のみを残す(1900/1/1　0:00:00は対象外とする為)
For Each cell In ws.Range("F3:F" & lastRow)
If Year(cell.Value) Like "20*" Then
cell.Value = Format(Hour(cell.Value) & ":" & Minute(cell.Value) & ":" & Second(cell.Value))
cell.NumberFormat = "h:mm"
End If
Next cell

' F列とG列の修正: 年月日を削除して時間のみを残す(1900/1/1　0:00:00は対象外とする為)
For Each cell In ws.Range("G3:F" & lastRow)
If Year(cell.Value) Like "20*" Then
cell.Value = Format(Hour(cell.Value) & ":" & Minute(cell.Value) & ":" & Second(cell.Value))
cell.NumberFormat = "[h]:mm"
End If
Next cell

' 修正結果を上書き保存
wb.Save
wb.Close

' メッセージ表示
MsgBox "データ修正が完了しました。", vbInformation
End Sub

回答No.2

chie65536（@chie65535）

追記。

24時間ピッタリのデータや24時間を超えたデータ、例えば「36時間30分」は「1.52083333333333」になるので、整数部を削ると「0.52083333333333」になり「12時間30分」になってしまいます。

日付データで、シリアル値がある程度小さい場合は「２４時間を超えた、時間だけのデータ」と見做して、加工しないようにして下さい。

例として挙げた
If Cells(1, 1).Value > 1 Then
を
If Cells(1, 1).Value > 100 Then
にすると良いでしょう。

こうするだけで「2400時間まではそのまま」になります。

因みに、2000年を超えた値は、シリアル値が「36526以上」になるので「36526以上の数値だけ加工する」としても良いです。

回答No.1

chie65536（@chie65535）

Excelの日付時刻のデータは数値（日時シリアル値）で記録されます。

時刻のみのデータ：２４時間を「１」とした、０以上１未満の数値。
02:53:34の場合「0.1205319444」が記録されます。

日付のみのデータ：1900/1/1を１とした日数。
2024/8/8の場合「45512」が記録されます。

日付時刻のデータ：1900/1/1を１とした日数と、２４時間を「１」とした、０以上１未満の数値を加算した数値
2024/8/8 02:53:34の場合「45512.1205319444」が記録されます。

簡単にいうと
時刻だけのデータ⇒１未満の小数点だけのデータ
日付だけのデータ⇒１以上の小数点の付かない整数のデータ
日付時刻のデータ⇒１以上の小数点が付いた実数のデータ
という事です。

ですので、日付付きデータから日時を削る場合は「元データから整数部を引き算して小数点だけにすれば良い」のです。

例えば、以下のマクロはA1セルの日付データを消し去ります。
Cells(1, 1).Value = Cells(1, 1).Value - Int(Cells(1, 1).Value)

ですが、このままでは「24:00」が「0:00」になってしまう（シリアル値が「１」の場合に「0:00」になってしまう）ので、
If Cells(1, 1).Value > 1 Then
Cells(1, 1).Value = Cells(1, 1).Value - Int(Cells(1, 1).Value)
End If
とすれば良いでしょう。

但し「24:00;01」は、シリアル値が１を超えているので「0:00;01」に変換されてしまうので注意して下さい。

お礼

ご教示ありがとうございました。 不備なマクロ実行時に、『1091271:00』などが出力されました。今回それらの時刻の仕組みがわかりました。

Powered by GRATICA