自動でマクロファイルにデータを入力し保存したい

質問

何時も、大変お世話になっております。
私の能力では、解決出来ず大変困っています。
稼働率や共用率、その他の値を計算してくれるExcelのマクロファイルに、機器毎にデータを入力し、計算が終わるとこのマクロファイルを別名で保存する作業を毎回手作業で行っています。
機器は250個程あり、大変な手間が掛かってしまいます。
また、手作業で別名でファイルを保存する為、入力ミスが生じでしまいます。
この作業を自動化したいのですが、やり方が全く分からず困っています。もし、自動化のやり方をご存じでしたら、ご教示をお願いいたします。
・データファイルは下記のようなフォーマットになっています。
・セルA2～セルAOの範囲の装置分のデータを、マクロファイルの入力用シート『カテゴリーログ』のセルA4から値張り付けで入力します。
・出力ファイル名は、『ステーション_グループ_装置ID_装置名.xlsx』としたいです

装置ID 装置名 ステーション グループ 利用日 開始時間 終了時間 利用時間 利用形態 ユーザーID 利用者 所属区分 所属機関 利用区分 提供AM 課題ID 課題名 利用係数 単価 内容消耗品 数量 実費物件費合計 単価 役職 数量 実費人件費合計 標準単価 適用単価 数量 共用設備等使用料合計 基準額 役職 "技術代行
係数" 単価 数量 合計 小計 間接経費 税抜き合計 消費税相当額 合計 単合税込 備考欄1 備考欄2 備考欄3
AB0016 AB6連装置 融合St 001F 2022/6/2 13:30 15:30 2 技術代行 500037 大谷 翔平 大企業 ソソ株式会社 NNF利用 22HH8041 GaN系プロセス 1 2000 CR料 2 4000 2 0 2 0 15000 研究、エン 2 30000 2 60000 64000 19200 83200 8320 91520
AB0019 化合物装置 融合St 001F 2022/6/2 12:00 13:00 1 機器利用 500174 吉田 知也 公的研究機関 A総合研究所 AAM利用 JPNM0003 シリフォト 0.3 2000 CR料 1 2000 1 0 1 0 15000 研究、エン 0 0 1 0 2000 0 2000 200 2200
AB0009 水蒸気装置 融合St 001F 2022/4/30 16:00 16:15 0.25 機器利用 500114 柏 翼 大学等 ABC大学 AAM利用 JPNM0009 Si熱電集積 0.3 2000 CR料 0.25 500 0.25 0 0.25 0 15000 研究、エン 0 0 0.25 0 500 0 500 50 550
AB0024 赤外線装置 融合St 001F 2022/4/30 16:15 17:00 0.75 機器利用 500172 高橋 正夫 大企業 ソレ株式会社 NNF利用 22HH8002 GaN系材料 1 2000 CR料 0.75 1500 0.75 0 0.75 0 15000 研究、エン 0 0 0.75 0 1500 450 1950 195 2145
AB0024 赤外線装置 融合St 001F 2022/6/30 15:15 16:15 1 機器利用 500172 高橋 正夫 大企業 ソレ株式会社 NNF利用 22HH8002 GaN系材料 1 2000 CR料 1 2000 1 0 1 0 15000 研究、エン 0 0 1 0 2000 600 2600 260 2860
AB0009 水蒸気装置 融合St 001F 2022/6/30 15:00 15:30 0.5 18913 河野 久機 装置管理 自主運用 0 0 CR料 0.5 0 0.5 0 0.5 0 15000 研究、エン 0 0 0.5 0 0 0 0 0 0
AB0030 顕微式測定 融合St 001F 2022/6/30 15:00 16:00 1 機器利用 500135 中前 秀一 大学等 BBB大学 NNF利用 22HH8046 半導体パルス 0.3 2000 CR料 1 2000 1 0 1 0 15000 研究、エン 0 0 1 0 2000 600 2600 260 2860
AB0018 多目的装置 融合St 001F 2022/5/30 14:45 15:30 0.75 機器利用 500071 清水 悦朗 大企業 セラ株式会社 NNF利用 22HH8014 フォト 1 2000 CR料 0.75 1500 0.75 0 0.75 0 15000 研究、エン 0 0 0.75 0 1500 450 1950 195 2145
AB0165 フェム装置 分析St 分析2 2022/5/30 9:00 17:00 8 装置管理 使用不可 0 8 0 8 0 8 0 0 8 0 0 0 0 0 0
AB0166 放電質分析 分析St 分析2 2022/6/8 9:00 0:00 15 10637 装置管理 NNMS 使用不可 メンテナンス 0 15 0 15 0 15 0 0 15 0 0 0 0 0 0
AB0166 グロー分析 分析St 分析2 2022/6/9 0:00 9:00 9 10637 装置管理 NNMS 使用不可 メンテナンス 0 9 0 9 0 9 0 0 9 0 0 0 0 0 0
AB0166 グロー分析 分析St 分析2 2022/6/9 9:30 11:30 2 技術代行 15986 高田 裕一 NNMS NNMS 内部利用 22HH5379 Ni基超の分析 0.1 2 0 2 0 2 0 15000 研究、エン 2 3000 2 6000 6000 0 6000 600 6600
AB0166 グロー分析 分析St 分析2 2022/6/9 13:30 15:30 2 技術代行 15986 高田 裕一 NNMS NNMS 内部利用 22HH5379 Ni基超の分析 0.1 2 0 2 0 2 0 15000 研究、エン 2 3000 2 6000 6000 0 6000 600 6600
AB0176 酸素22装置 分析St 分析2 2022/6/1 14:00 15:00 1 20546 装置管理 自主運用 0 1 0 1 0 1 0 0 1 0 0 0 0 0 0
AB0169 簡易型粉末 分析St X回折 2022/5/8 11:30 13:30 2 機器利用 20458 田代 知美 NNMS スマート材料 内部利用 22HH5082 0.1 2 0 2 0 2 0 0 2 0 0 0 0 0 0
AB0169 簡易型粉末 分析St X回折 2022/5/8 13:40 15:40 2 機器利用 20729 直井 今子 NNMS 熱エネ材料 内部利用 22HH5176 0.1 2 0 2 0 2 0 0 2 0 0 0 0 0 0
AB0169 簡易型粉末 分析St X回折 2022/6/9 9:00 9:30 0.5 8101 上瀬 直美 NNMS 分析ステ 使用不可 メンテナンス 0.5 0 0.5 0 0.5 0 0.5 0 0 0 0 0 0
AB0169 簡易型粉末 分析St X回折 2022/6/13 14:00 15:30 1.5 機器利用 21015 タラチャンド NNMS 変換材料 内部利用 22HH5176 0.1 1.5 0 1.5 0 1.5 0 0 1.5 0 0 0 0 0 0
AB0081 X線光電子 融合St 002F 2022/4/2 9:30 10:00 0.5 技術代行 15659 李 ー勝 NNMS 内部利用 22HH5111 Two 0.1 0.5 0 0.5 0 0.5 0 15000 研究、エン 1.2 1800 0.5 900 900 0 900 90 990
AB0085 多連S装置 融合St 002F 2022/4/2 16:30 17:00 0.5 13109 装置管理 自主運用 0 0.5 0 0.5 0 0.5 0 0 0.5 0 0 0 0 0 0
AB0085 多連S装置 融合St 002F 2022/4/2 9:30 11:00 1.5 技術代行 18311 ロダ オマル NNMS 内部利用 22HH5034 人工シナプス 0.1 1.5 0 1.5 0 1.5 0 15000 研究、エン 1.2 1800 1.5 2700 2700 0 2700 270 2970
AB0095 SEM3装置 融合St 002F 2022/6/2 14:00 16:00 2 技術代行 17769 チェンフイ NNMS 内部利用 22HH5365 高次構造 0.1 2 0 2 0 2 0 15000 研究、エン 1.2 1800 2 3600 3600 0 360

回答No.36

kkkkkm · ベストアンサー

> 　装置の稼働率-共用率ファイル中に連番を付ける事は出来ませんでした。

連番ではなく
もし、「装置の稼働率-共用率_xxxxxx-xxxxxx.xlsx」にデータ転記後、A列、B列、C列のいずれかが「空白になる」可能性がある場合、データが上下デコボコに転記されてしまいます。

たとえばB列(グループ)に空白があった場合

A, B, C, D, E列
あ,い,う,え,お　1件目
か,空,く,け,こ　2件目
さ,し,す,せ,そ　3件目

上記のように転記されるのが本来ですが
空白があると下記のように転記されてしまいます。

A, B, C, D, E列
あ,い,う,え,お　1件目
か,し,く,け,こ　2件目
さ,空,す,せ,そ　3件目

> ST名 グループ 装置ID（資産番号）

上記がA列、B列、C列で空白になる可能性がないのでしたら変更しなくてもいけます。

先日「#DIV/0!」の件があったので、上記のセルで空白のセルが存在する可能性もあるのかなと思っての変更提案です。

連番は手作業でお願いします。

お礼

大変お世話になっております。
最終的な確認は一応完了しました。
この質問については、これで完了と致します。
今回の質問から困った事、分からない事が新たに発生した場合は、再度ご質問をさせて頂きますので、何卒よろしくお願い申し上げます。
最終までご教授下さり、本当にありがとうございました。

補足

大変お世話になっております。
更にかみ砕いたご教示ありがとうございました。

下記、理解しました。　連番は手作業で作成する事に致します。
『先日「#DIV/0!」の件があったので、上記のセルで空白のセルが存在する可能性もあるのかなと思っての変更提案です。』

では、回答35でご教示頂いたｽｸﾘﾌﾟﾄの箇所は、元へ戻した方がよろしいでしょうか？

回答No.26

kkkkkm

あと

実行を中止しますか?
が出た後に

Call M_Clear(MSheet)
でカテゴリーログのデータをクリアしています、これだとどこで止めたのか分からなくなると思いますので

If MsgBox("実行を中止しますか?", vbQuestion + vbYesNo) = vbYes Then ' Err.Description
の下の
Call M_Clear(MSheet)
をコメントにしておいてください。

また

Windowsのエラーメッセージが無く「実行を中止しますか」だけなので意味が分からないと思いますから
Windowsのエラーメッセージも含めてメッセージを出すように以下に変更するか

If MsgBox(Err.Description & vbCrLf & vbCrLf & "実行を中止しますか?", vbQuestion + vbYesNo) = vbYes Then

Windowsのエラーメッセージがエラーに対しに正しい文言とは限らないこともありますので

If MsgBox("ファイル保存時にエラーになりました" & vbCrLf & vbCrLf & "実行を中止しますか?", vbQuestion + vbYesNo) = vbYes Then

のどちらかにしておいてください。

回答No.25

kkkkkm

> この3つの装置名には半角『/』が入っていました。これが原因でした。

原因がわかって良かったです。

ファイル名に使えない文字をマクロで「-」もしくは半角から全角に変換できますので

Dim BadStr As Variant, j As Long

をDimの塊の最後に追加して

BadStr = Array("\", "/", ":", "*", "?", """", "<", ">", "|")

を

Set DataWb = Workbooks("稼働率用データ.xlsm")

の前に追加して

For j = LBound(BadStr) To UBound(BadStr)

'↓「-」に変更する場合
' NewBookName = Replace(NewBookName, BadStr(j), "-")

'↓全角に変更する場合
' If BadStr(j) = "\" Then
' NewBookName = Replace(NewBookName, BadStr(j), "￥")
' ElseIf BadStr(j) = """" Then
' NewBookName = Replace(NewBookName, BadStr(j), "ー")
' Else
' NewBookName = Replace(NewBookName, BadStr(j), StrConv(BadStr(j), vbWide))
' End If

Next

を
'マクロ無しのブックに保存できないというメッセージが一度出ますがOkしてください。
On Error Resume Next

の前に追加してください。

「\」は StrConvで全角に変換できないので全角の「￥」を指定して変換しています。
「"」の全角をファイル名に使うと保存したファイルが開かなかったので「ー」に変換しています。

ファイル名だけの変更ですので元のデータは変更していません。

> 20回に一度一時停止』をしないように設定しようと思いますが、問題無いでしょうか？

はい、その部分をコメントにすると停止しなくなります。

あと

MaxCnt = 216

の部分は、実際の件数と違っていても、ステータスバーの横に伸びていくバーのようなものの表示に誤差が(と言ってもMaxCntの値を100%として20分割なので余程違わない限り差は無いと思います)出ますが、件数の表示には影響がありませんから、あまりシビアにならなくてもいいと思います。

それと、もし既存のファイルに強制的に上書きしてよろしければ

ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

よりコピーを保存する

ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewBookName

の方が早いです。

回答No.24

kkkkkm

回答No.22の一部訂正です。

Debug.Print "FileName= "; NewBookName '←これを追加してください

だとファイル名が空の時に何回目の時なのか分からないので
を以下に変更してください。

Debug.Print "FileName= "; NewBookName; " ::"; cnt; "回目" '←これを追加してください

補足

大変お世話になっております。
早速のご教示を頂き、大変助かりました。有難うございます。
①本日も、ご教示頂いた通りにｽｸﾘﾌﾟﾄを変更して、マクロを実行しました。
　マクロ4回目(8/7夜)と本日5回目の結果が同じになりました。
　3回目では、NMRStのAB001～AB004の4つの装置と、3つ合わせて7つの装置の出力ファイルがされませんでしたが、
　4回目、5回目では、作成出来なかった出力ファイルは3個になりました。
　そして、3個の装置の出力ファイルが作成出来ない原因がわかりました。
　もっと、早い段階で気づくべきでした、
　色々とご心配をお掛けしてしまい申し訳ありませんでした。
　この3つの装置名には半角『/』が入っていました。これが原因でした。
　装置名に入っている半角『/』を半角『-』へ変更しマクロを実施したら、正常に出力ファイルが作成されました。
　因みに、NMRStのAB001～AB004の4つの装置名には、『[』『]』『(』『)』が入っています。
　全角『/』は問題ないようでした。
　※装置名が入っているデータファイルは、仰る通り、2行目からデータが入っています。

②装置の稼働率-共用率_202204-202206.xlsxには、お願いしたグループ名が記載されました。ありがとうございました。

③作業完了件数についてもカウントが表示されて、とても確認し易くなりました。

④『20回に一度一時停止』をしないように設定しようと思いますが、問題無いでしょうか？
　確か、下記のｽｸﾘﾌﾟﾄをコメントアウトすればよろしいでしょうか？

'20回に一度一時停止します。
If cnt Mod 20 = 0 Then
MsgBox "一時停止中" & vbCrLf & vbCrLf & "Okで続行します", vbInformation
End If

⑤7月分のデータを結合して、再度マクロをテストする事にします。
　愚鈍な自分に、いつもかみ砕いたご教示を下さり本当に心から感謝致します。
　大変恐縮ですが、本番までもう少しご指導頂けたら大変助かります。

回答No.23

kkkkkm

> 　※この時は、マクロの[カテゴリーログ」にデータコピーの画面が出て来なかった。

すみません、これの事を忘れてました。
データがコピーされていない状態で先に進んでいるということでしょうか。

共用部門装置IDの2行目からデータは始まっていると思っているのですがいかがでしょう。
テーブルの2行目から「AB004」などのデータがあると考えてます。

しかし、最初に一回一回止めてコピーされるか試していただいたときには正しくコピーされていましたし、そのあたりは全く同じコードなので、違いが出るとは思えないのですが・・・。

回答No.22

kkkkkm

変更後のコードをこちらにコピペして実行しました。NMRStで生成させるファイル名の一部のデータが無かったので適当に他からコピペしてとりあえずエラーは出ませんでした。

何度もテストしていただきありがとうございます。

同じ塊の時にエラーが出ているみたいなので、もしかしたらファイル名として使えない文字があるのか、その時に何らかの原因でファイル名の生成がうまくいっていないのか、どちらかなのかと思いましたので

エラーの処理の所に

If Err.Number <> 0 Then

Debug.Print "FileName= "; NewBookName '←これを追加してください

If MsgBox("実行を中止しますか?", vbQuestion + vbYesNo) = vbYes Then ' Err.Description

として、マクロの画面の「イミディエイト」に表示されたファイル名が正しかどうか確認してみてください。
「イミディエイト」が無い場合メニューの「表示」で「イミディエイトウィンドウ」を選択してください。

> 　[Summary3]の値に『グループ名』を追記したいのですが可能でしょうか？

TestLast()の

> '上から下記ｽｸﾘﾌﾟﾄをここへ移動する20220807
> FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column).Value = _
> ThisWorkbook.Sheets("Summary3").Range("A2:AA2").Value

を以下に変更してください。

'上から下記ｽｸﾘﾌﾟﾄをここへ移動する20220807
FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Value = ThisWorkbook.Sheets("Summary3").Range("A2").Value
FinalDataSheet.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0).Value = MSheet.Range("D5").Value
FinalDataSheet.Cells(Rows.Count, "C").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column - 1).Value = _
ThisWorkbook.Sheets("Summary3").Range("B2:AA2").Value

それと

Make_File_Openの

> NewFile.Sheets(1).Range("A1:AA1").Value = ThisWorkbook.Sheets("Summary3").Range("A1:AA1").Value

を

を以下に変更してください。

NewFile.Sheets(1).Range("A1").Value = ThisWorkbook.Sheets("Summary3").Range("A1").Value
NewFile.Sheets(1).Range("B1").Value = ThisWorkbook.Sheets("カテゴリーログ").Range("D4").Value
NewFile.Sheets(1).Range("C1:AB1").Value = ThisWorkbook.Sheets("Summary3").Range("B1:AA1").Value

回答No.21

kkkkkm

ふと思いついてやってみたのですが、マクロ有で保存する場合ファイルのコピーを保存したほうがより早くなります。

回答No.18の以下の部分の後半部分

> マクロ有のまま保存したほうがこちらのテストではかなり早くなりました。
> 変更する場合
>
> NewBookName = .Range("C5").Value & "_" & .Range("D5").Value & "_" & .Range("A5").Value & "_" & .Range("B5").Value & ".xlsx"
>
> を
>
> NewBookName = .Range("C5").Value & "_" & .Range("D5").Value & "_" & .Range("A5").Value & "_" & .Range("B5").Value & ".xlsm"
>
> に変更するのと

上記は↑この状態で変更していただいて

下記の

> ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbook
>
> を
>
> ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

の部分を以下に読み替えてください。

ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbook

を

ThisWorkbook.SaveCopyAs ThisWorkbook.Path & "\" & NewBookName

にしてみてください。

補足

ｽｸﾘﾌﾟﾄの続きです。
Application.ScreenUpdating = True
Application.StatusBar = False 'ステータスバーの解除
MsgBox "処理が終了しました", vbInformation
Set FinalDataBook = Nothing
Set FinalDataSheet = Nothing
Set DataWb = Nothing
Set MSheet = Nothing

End Sub

Function Make_File_Open(ByVal M_Path As String, ByRef DataWb As Workbook) As String
Dim NewFileName As String
Dim NewSheetName As String
Dim NewFile As Workbook
Dim NewFilePath As String
Dim MonthP As String

With DataWb.Worksheets("結合_OK").ListObjects("テーブル1")
MonthP = Format(CVDate(WorksheetFunction.Min(.ListColumns("利用日").DataBodyRange)), "yyyymm") & "-" & _
Format(CVDate(WorksheetFunction.Max(.ListColumns("利用日").DataBodyRange)), "yyyymm")
End With

NewFileName = "装置の稼働率-共用率_" & MonthP & ".xlsx"
NewSheetName = "稼働率-共用率_" & MonthP

NewFilePath = M_Path & "\" & NewFileName
If Dir(NewFilePath) = "" Then
Set NewFile = Workbooks.Add
NewFile.Sheets(1).Name = NewSheetName
NewFile.Sheets(1).Range("A1:AA1").Value = ThisWorkbook.Sheets("Summary3").Range("A1:AA1").Value
NewFile.SaveAs NewFilePath
Set NewFile = Nothing
Else
If MsgBox("既に" & vbCrLf & vbCrLf & NewFileName & vbCrLf & vbCrLf & "というファイルは存在します。" & vbCrLf & vbCrLf & _
"既存のファイルを開きますか?", vbQuestion + vbYesNo) = vbYes Then
Workbooks.Open NewFilePath
If MsgBox("処理を続行しますか？", vbQuestion + vbYesNo) = vbYes Then
'next
Else
MsgBox "処理を中止します", vbInformation
End
End If
Else
MsgBox "処理を中止します", vbInformation
End
End If
End If

Make_File_Open = NewFileName & "," & NewSheetName

End Function

回答No.20

kkkkkm

ファイルの保存がエラーの原因かどうか調べる場合は

On Error Resume Next
ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbook

をコメントにしたらファイルの保存をしなくなります。
その状態で「実行を中止しますか?」が出ずに最後まで実行できたらファイルの保存がエラーの原因だと言えると思います。

ファイルの保存をしないので実行時間は数分もかからないと思います。

補足

大変お世話になっております。
まだ、ｽｸﾘﾌﾟﾄは修正していませんが、回答19で頂いたご教示通りでｽｸﾘﾌﾟﾄを修正し、3回目のマクロを実施しました。
下記へそのｽｸﾘﾌﾟﾄを回答20、回答21で記載します。
Sub TestLast()
Dim DataWb As Workbook, FinalDataBook As Workbook
Dim MSheet As Worksheet, FinalDataSheet As Worksheet
Dim i As Long, FRow As Long, ERow As Long
Dim IDCol As Long
Dim NewBookName As String
Dim cnt As Long
Dim FinalaDataTmp As String
Dim rc As VbMsgBoxResult
rc = MsgBox("マクロを実行しますか？", vbYesNo + vbQuestion, "■■■～～■■■")
If rc = vbYes Then
'next
Else
MsgBox ("処理を中止します"), vbCritical
Exit Sub
End If
Set DataWb = Workbooks("稼働率用データ.xlsm")
Set MSheet = ThisWorkbook.Sheets("カテゴリーログ")
'装置の稼働率-共用率ファイルのフォルダを変更したい場合ThisWorkbook.Pathを変更する
FinalaDataTmp = Make_File_Open(ThisWorkbook.Path, DataWb)
Set FinalDataBook = Workbooks(Split(FinalaDataTmp, ",")(0))
Set FinalDataSheet = FinalDataBook.Sheets(Split(FinalaDataTmp, ",")(1))
Call M_Sort(DataWb)
Call M_Clear(MSheet)
'Application.ScreenUpdating = False
With DataWb.Worksheets("結合_OK").ListObjects("テーブル1")
IDCol = .ListColumns("共用部門装置ID").DataBodyRange.Column
FRow = 2: cnt = 1
For i = 2 To .Range.Rows.Count
If .Range.Cells(i, IDCol).Value <> .Range.Cells(i + 1, IDCol).Value Then
ERow = i
'項目の列は45列
MSheet.Cells(5, "A").Resize(ERow - FRow + 1, 45).Value = _
.Range.Cells(FRow, 1).Resize(ERow - FRow + 1, 45).Value
FRow = ERow + 1
With MSheet
NewBookName = .Range("C5").Value & "_" & .Range("D5").Value & "_" & .Range("A5").Value & "_" & .Range("B5").Value & ".xlsm"
End With
'下へ移動した20220807　FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column).Value = _
ThisWorkbook.Sheets("Summary3").Range("A2:AA2").Value
'ステータスバーの部分ここから
Dim sStatus As String
Dim MaxCnt As Long
MaxCnt = 216
sStatus = "[ " & cnt & "件目 ]" & "　を処理中…"
sStatus = sStatus & String(Int((cnt / MaxCnt) * 20), "■")
sStatus = sStatus & String(20 - Int((cnt / MaxCnt) * 20), "□")
Application.StatusBar = sStatus
'ステータスバーの部分ここまで
'マクロ無しのブックに保存できないというメッセージが一度出ますがOkしてください。
On Error Resume Next
ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
If Err.Number <> 0 Then
If MsgBox("実行を中止しますか?", vbQuestion + vbYesNo) = vbYes Then ' Err.Description
Call M_Clear(MSheet)
Application.ScreenUpdating = True
Application.StatusBar = False 'ステータスバーの解除
Exit Sub
End If
End If
Err.Clear
On Error GoTo 0
' MsgBox "次へ"
' Stop
DoEvents
'上から下記ｽｸﾘﾌﾟﾄをここへ移動する20220807
FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column).Value = _
ThisWorkbook.Sheets("Summary3").Range("A2:AA2").Value
'20回に一度一時停止します。
If cnt Mod 20 = 0 Then
MsgBox "一時停止中" & vbCrLf & vbCrLf & "Okで続行します", vbInformation
End If
cnt = cnt + 1
Call M_Clear(MSheet)
End If
Next
End With

回答No.19

kkkkkm

あと、気になったのですが、「装置の稼働率-共用率」にSummary3からのデータ転記を「データファイル」から「マクロファイル」へ塊をコピペしたすぐ後に実行しているところです。

たしか、コピペしたら数式で計算してSummary3が変化するという事だったと思いますので、もしかしたら計算が終わる前に転記してしまう可能性があるのかなと思ったりしますので、念のために転記の場所をファイル保存の後にしてもらえますでしょうか。
(この場合、ファイル保存でエラーが出て「実行を中止」した場合そのデータは転記されません、中止しないと転記されます)

FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column).Value = _
ThisWorkbook.Sheets("Summary3").Range("A2:AA2").Value
を

DoEvents

のすぐ後ろに移動したほうがいいのかなと思います。

こんな感じになります
もとの DoEvents

FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column).Value = _
ThisWorkbook.Sheets("Summary3").Range("A2:AA2").Value

もとの cnt = cnt + 1

また
If cnt Mod 20 = 0 Then
MsgBox "一時停止中" & vbCrLf & vbCrLf & "Okで続行します", vbInformation
End If
を追加している場合は

こんな感じになります。

もとの DoEvents

FinalDataSheet.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(1, Columns("AA").Column).Value = _
ThisWorkbook.Sheets("Summary3").Range("A2:AA2").Value
追加した If cnt Mod 20 = 0 Then
追加した MsgBox "一時停止中" & vbCrLf & vbCrLf & "Okで続行します", vbInformation
追加した End If

もとの cnt = cnt + 1

お礼

大変お世話になっております。
沢山のマクロのご教示ありがとうございました。
マクロのｽｸﾘﾌﾟﾄを修正し、実行致しました。
昨夜2回実行した結果と変化が無かったようです。
・ｽｸﾘﾌﾟﾄ修正後のマクロ実施結果は、時間経過で以下の通りでした。
　①マクロスタート
　　メッセージボックスに『実行を中止しますか？』が5回出力された、何れも『いいえ』で継続した。
　　※この時は、マクロの[カテゴリーログ」にデータコピーの画面が出て来なかった。
　②これ以降は、マクロの[カテゴリーログ」にデータコピーの画面が表示されている。
　　メッセージボックスに『実行を中止しますか？』が2回出力された。
　③これ以降は、メッセージボックスに『一時停止中OKで継続します。』表示されたので、『OK』で継続する。

　マクロは昨夜から3回実行しました。
　3回共に最初のデータコピーで、『実行を中止しますか？』が4回続けて出て、
　ステーション_グループ_装置ID_装置名.xlsxのファイルが作成されませんでした。
　このステーション名は『NMRSt』で、装置IDは、AB001～AB004になります。
　『NMRSt』はデータのすべてでステーション_グループ_装置ID_装置名.xlsxのファイルが作成されませんでした。
　　確認した所、『実行を中止しますか？』で7回出力された装置では、ステーション_グループ_装置ID_装置名.xlsxのファイルが作成されなかったようです。
稼働率-共用率_202204-202206.xlsxのファイルは装置IDの数分稼働率等の値が入っているので、こちらは正常でした。

・[カテゴリーログ]にデータをコピーさせて、[Summary3]の値を装置の稼働率-共用率_202204-202206.xlsxへコピーさせた時点で、作業を停めて、ステーション_グループ_装置ID_装置名.xlsxのファイルの作成状況を確認した方がよいでしょうか？　ここまで出来ているので、もう少しの所かなと思うのですが。
この後、補足に修正済みのｽｸﾘﾌﾟﾄを記載させて頂きます。

・[Summary3]の値を、ステーション_グループ_装置ID_装置名.xlsxへ保存する件ですが、今毎になって大変申し訳ありません。
　[Summary3]の値をそのままステーション_グループ_装置ID_装置名.xlsxへ保存をお願いしましたが、
　[Summary3]の値に『グループ名』を追記したいのですが可能でしょうか？
　マクロファイルには、[Summary3]の他に[Log]と言うシートがありまして、データファイルを[カテゴリーログ]へコピーすると、[Log]シートもコピーした情報へ変更するようになっています。
　[Log]のセルC1の値(グループ名：分析)、
　又は、[カテゴリーログ]のセルD2の値(グループ名：分析)のどちらかのグループ名を下記のように、2列目に追加出来たらと思います。
　因み、[Log]のセルC1は[カテゴリーログ]のリンク値になります。
　ST名 装置ID 装置名　　　装置稼働率　外部共用率　内部共用率 装置共用率　設備共用（日）　外部共用（日）その他。。。。。
分析St AB0165 フェム装置　　3% 　　50%　　　　50% 　　100% 2 　　　　1
　　　↓
ST名 グループ　装置ID　　装置名 装置稼働率 外部共用率 内部共用率 装置共用率 設備共用（日） 外部共用（日）　その他。。。。。
分析St 分析　　　AB0165　　フェム装置 　　3% 　　　　　　50%　　　　 　　50% 　　　　　　100% 　　　2 　　1

以上　宜しくお願い致します。

回答No.18

kkkkkm

> ・『マクロ無しのブックに保存できないというメッセージ』や『マクロを中止しますか』
> 　が数回出るのは、何か原因とかありますでしょうか？

「実行を中止しますか?」でしたらファイルの保存時にエラーになった場合に出ます。
何らかの原因で保存ができなかった場合や、既にファイルがある場合の「上書き確認」で「上書きしない」を選んだ場合にエラーになります。
今回の場合は、連続して保存しているために処理が追い付かずにエラーになっているのではないかと思います。
本来エラーで止まるのですが、途中で止めるよりは保存できなかったのはスキップして次の塊に進んだ方がいいと思ったのでそのような処理にしています。

連続して保存しているためにエラーになってる場合、途中でメッセージを出して一旦停止すると出なくなるかもしれません。

DoEvents
の後に
If cnt Mod 20 = 0 Then
MsgBox "一時停止中" & vbCrLf & vbCrLf & "Okで続行します", vbInformation
End If
を追加すると20回に一度一時停止します。

ただ、下記の変更をしてエラーが出ない場合は一時停止をしなくていいと思います。

並び替えのマクロは最初に一度しか実行していませんのでエラーとは関係ないと思います。
『マクロ無しのブックに保存できないというメッセージ』は、一番最初にマクロ有のファイルをマクロ無のファイルとして保存しているので出てしまいます。マクロ有のまま保存すると出なくなります。

マクロ有のまま保存したほうがこちらのテストではかなり早くなりました。
変更する場合

NewBookName = .Range("C5").Value & "_" & .Range("D5").Value & "_" & .Range("A5").Value & "_" & .Range("B5").Value & ".xlsx"

を

NewBookName = .Range("C5").Value & "_" & .Range("D5").Value & "_" & .Range("A5").Value & "_" & .Range("B5").Value & ".xlsm"

に変更するのと

ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbook

を

ThisWorkbook.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbookMacroEnabled

変更してください。

> 作業に約80分かかりました。

かなりかかるのですね・・・。
上記(マクロ有のまま保存)の変更と
最初の方にある
'Application.ScreenUpdating = False
これを有効にしていないのでしたら、有効にすると画面の表示(コピペしている状態)を止めますので、処理が早くなると思います。

> こちらから、再度結果等をご報告しご教示を頂きたい時は『補足』に記載でよろしいでしょうか？

はい、補足でいいです。ただ、補足に記載した場合nnirosanさんのお礼率が下がるかもしれません(このあたりの算出方法はよくわかりません)ので、お礼率が気になる場合はお礼の方がいいと思います。

回答No.17

kkkkkm

> 下記のようなコンパイルエラーがでましたので、大変お手数ですが、対処方法を教えて頂きたいです。

回答No.15のコードを同じ場所に追加してください。

補足

長期に渡り、ご教示ありがとうございます。
本当に頭が下がります。
・補足を記載した後、直ぐ気づいて回答№15を追記しました。
　『マクロ無しのブックに保存できないというメッセージ』と『マクロを中止しますか』が5,6回繰り返し出たので、『はい』の後にマクロは中止しないとした後は、
　聞いて来なくなり、時々、『マクロを中止しますか』が数回出ましたが、再度まで行きました。

・作成された、装置の稼働率-共用率_202204-202206.xlsxには、216行のSummay3の結果が記載されましたが、
　作成した、ステーション_グループ_装置ID_装置名.xlsxのファイルは、209個でした。
装置は250個とお知らせしておりましたが、4月～6月に使用したのは、216個でした。
間違ってお伝えしていました、申し訳ありません。

・『マクロ無しのブックに保存できないというメッセージ』や『マクロを中止しますか』
　が数回出るのは、何か原因とかありますでしょうか？
　データファイルにマクロ(マクロの記録で作成した並び替えのマクロ)が入っているせいでしょうか？

・再度、マクロを起動させています。
　前回、作業に約80分かかりました。マクロの作業が完了しましたら、再度結果を確認します。
すみませんが、また結果をご報告させて頂きます。

こちらから、再度結果等をご報告しご教示を頂きたい時は『補足』に記載でよろしいでしょうか？

以上　宜しくお願い致します。