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

質問

何時も、大変お世話になっております。
私の能力では、解決出来ず大変困っています。
稼働率や共用率、その他の値を計算してくれる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.16

kkkkkm

説明し忘れてました。

装置の稼働率-共用率のファイルはデータ転記後に保存していませんので、最後に手動で保存してください。

補足

大変お世話になっております。
自動作成マクロの作成ありがとうございました。
マクロを実行しましたら、下記のようなコンパイルエラーがでましたので、大変お手数ですが、対処方法を教えて頂きたいです。

'装置の稼働率-共用率ファイルのフォルダを変更したい場合ThisWorkbook.Pathを変更する
FinalaDataTmp = Make_File_Open(ThisWorkbook.Path, DataWb)
　　　　　　　　　　　　　　↓
上記の『Make_File_Open』の所で、コンパイルエラーで出ました。『Subまたはfunctionが定義されていません』
以上　宜しくお願い致します。

回答No.15

kkkkkm

これも追加しておいてください。

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.14

kkkkkm

Function M_Clear(ByRef MSheet As Worksheet)
と
Function M_Sort(ByRef DataWb As Workbook)
以外のコードです。

最後までノンストップで処理します。

データファイルは開いてから実行してください。
実行すると装置の稼働率-共用率ファイルがなければ作成し開きます。
あれば、既存にあるというメッセージが出るので対応してください。

ステーション_グループ_装置ID_装置名.xlsx
が、既にあれば上書きするかどうか確認が出ます。
上書きしない場合、その後「実行を中止」かどうか聞いてきますので中止すると止まり、中止しない場合は次の塊に進みます。

'ステータスバーの部分ここから
'ステータスバーの部分ここまで
の間を有効にすると、左下のステータスバーに進行状況(件数と割合のバー)が表示されます。
バーは250件を100%で計算していますので、バーの状況表示はほぼそのあたりまで終わっていると考えてください。

'Application.ScreenUpdating = False
を有効にすると画面の表示(コピペしている状態)を止めますので、処理が早くなると思います。

途中で止めて確認しながら処理したい場合は

' MsgBox "次へ"
' Stop
のどちらかを有効にしてください。
どちらがどういった動作なのか回答No.11で説明していますので確認してください。

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("実際のデータファイル名に変更")
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 & ".xlsx"
End With
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 = 250
' 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:=xlOpenXMLWorkbook
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
cnt = cnt + 1
Call M_Clear(MSheet)
End If
Next
End With

Application.ScreenUpdating = True
Application.StatusBar = False 'ステータスバーの解除
MsgBox "処理が終了しました", vbInformation
Set FinalDataBook = Nothing
Set FinalDataSheet = Nothing
Set DataWb = Nothing
Set MSheet = Nothing

End Sub

次の回答へ

回答No.13

kkkkkm

> 　例えば、今回は、4/1～6/30のデータの場合は、稼働率-共用率_202204-202206となります。

マクロを実行した日じゃなくて、データファイルの利用日の最小の月と最大の月から取り出すのですね。

前回ファイル名とシート名のパターンは
装置の稼働率-共用率_202204-202206
稼働率-共用率-202204-202206
でしたが、両方とも
稼働率-共用率_202204-202206
というパターンでいいのでしょうか。

データファイルで以下のマクロを実行して正しくメッセージボックスにファイル名が取り出せたか確認してみてください。

Sub TestDate()
Dim MonthP As String
With Worksheets("結合_OK").ListObjects("テーブル1")
MonthP = Format(CVDate(WorksheetFunction.Min(.ListColumns("利用日").DataBodyRange)), "yyyymm") & "-" & _
Format(CVDate(WorksheetFunction.Max(.ListColumns("利用日").DataBodyRange)), "yyyymm")
End With
MsgBox "稼働率 -共用率_" & MonthP
End Sub

補足

大変お世話になります。
説明があやふやな所があり申し訳ありません。
頂いたマクロを実行し、『稼働率 -共用率_202204-202206』と
メッセージボックスにファイル名が出ましたのでご報告致します。

回答No.12

kkkkkm

ファイル名を生成の確認ですが、一年と翌年一日分のデータを一気に作成して確認していただいた方が早いとも思われますので一覧を作成するマクロです。

ファイル名生成を確認していただいたら、次回は最終のマクロを紹介できると思います。

A列に日付(366行、以下同じ行数)
B列にファイル名
H列にシート名
を一覧で記載します。

Sub Test()
Dim i As Long
Range("A1").Value = "2022/1/1"
Call Make_File_Open_Test(Range("A1").Value, 1)
For i = 1 To 365
Cells(i + 1, "A").Value = DateAdd("D", i, Range("A1").Value)
Call Make_File_Open_Test(Cells(i + 1, "A").Value, i + 1)
Next

End Sub

Function Make_File_Open_Test(ByVal mDate As Date, ByVal i As Long)
Dim NewFileName As String
Dim NewSheetName As String
Dim MonthP As String

If Month(mDate) = 1 Or Month(mDate) = 4 Or Month(mDate) = 7 Or Month(mDate) = 10 Then
MonthP = Format(mDate, "yyyymm") & "-" & Format(DateAdd("m", 2, mDate), "yyyymm")
ElseIf Month(mDate) = 2 Or Month(mDate) = 5 Or Month(mDate) = 8 Or Month(mDate) = 11 Then
MonthP = Format(DateAdd("m", -1, mDate), "yyyymm") & "-" & Format(DateAdd("m", 1, mDate), "yyyymm")
ElseIf Month(mDate) = 3 Or Month(mDate) = 6 Or Month(mDate) = 9 Or Month(mDate) = 12 Then
MonthP = Format(DateAdd("m", -2, mDate), "yyyymm") & "-" & Format(mDate, "yyyymm")
End If
NewFileName = "装置の稼働率-共用率_" & MonthP & ".xlsx"
NewSheetName = "稼働率-共用率_" & MonthP
Cells(i, "B").Value = NewFileName
Cells(i, "H").Value = NewSheetName
End Function

補足

大変お世話になってしまし大変恐縮です。
定期的に資料を出して下さいと言われているので大変助かります。

・データコピーと稼働率等の確認は、3/4程完了しました。
　データコピーも稼働率の値等も問題ない事を確認しました。

・また、出力ファイル名についても、サクッとマクロを作成頂きありがとうございました。マクロ実行出来ました。
　こんな事も出来てしまうのですね！
　試料作成の頻度は、月毎、4ヶ月毎、半年毎、年度毎ぐらいかなと思っていますので、
　可能であれば入力データの期間をファイル名に付けられると大変助かります。
　例えば、今回は、4/1～6/30のデータの場合は、稼働率-共用率_202204-202206となります。

稼働率等の自動作成マクロ、宜しくお願い致します。

回答No.11

kkkkkm

> テストをする事は大切ですので、この後全てのデータについて、コピー状態の確認をします。

実際の実行時にも確認する場合ですが、回答No.9のような状態でマクロ画面で実行して確認しながらというのと、メッセージボックスを表示してコピペした時点で止めて確認するという方法があります。

前者の場合は、画面をスクロールするなどの操作ができますが、間違ってマクロを終了してしまう可能性があり、その場合最初からやり直しになってしまいます。
後者の場合は、画面の操作ができませんので、止まったときに表示されている部分だけの確認になります。

> 新しいExcelのファイル(装置の稼働率-共用率_202204-202206.xlsx)
> 　 Sheet名＝(稼働率-共用率-202204-202206)へ保存出来たらと思います。

マクロで新しく作成するという事だと思いますので、ファイル名の考え方を確認するマクロです。
(日付の部分がない場合でしたら、一度作成すればいいので手動で作成していいのではと思います)

多分8月に実行すると

ファイル名＝装置の稼働率-共用率_202207-202209.xlsx
シート名＝稼働率-共用率_202207-202209

になるという考え方でいいと思うのですが、確認のためにファイル名を生成するところだけのマクロを作成しました。
テスト用なので新しいブックの適当なシートのタブを右クリックして「コードの表示」をクリックして出たマクロの画面に以下のコードをコピペしてください。

シートのA1に日付を入れるとB1にファイル名、B2にシート名が表示されます。
A1に入力した日付が、実際はマクロを実行した日付となりますので、適当な日付を入れて表示されたファイル名などがその日に対応するファイル名として正しいか確認してみてください。

Function Make_File_Open_Test(ByVal mDate As Date)
Dim NewFileName As String
Dim NewSheetName As String
Dim MonthP As String

If Month(mDate) = 1 Or Month(mDate) = 4 Or Month(mDate) = 7 Or Month(mDate) = 10 Then
MonthP = Format(mDate, "yyyymm") & "-" & Format(DateAdd("m", 2, mDate), "yyyymm")
ElseIf Month(mDate) = 2 Or Month(mDate) = 5 Or Month(mDate) = 8 Or Month(mDate) = 11 Then
MonthP = Format(DateAdd("m", -1, mDate), "yyyymm") & "-" & Format(DateAdd("m", 1, mDate), "yyyymm")
ElseIf Month(mDate) = 3 Or Month(mDate) = 6 Or Month(mDate) = 9 Or Month(mDate) = 12 Then
MonthP = Format(DateAdd("m", -2, mDate), "yyyymm") & "-" & Format(mDate, "yyyymm")
End If
NewFileName = "装置の稼働率-共用率_" & MonthP & ".xlsx"
NewSheetName = "稼働率-共用率_" & MonthP
Range("B1").Value = NewFileName
Range("B2").Value = NewSheetName
End Function

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range("A1").Address Then
Call Make_File_Open_Test(Range("A1").Value)
Range("A1").Select
End If
End Sub

回答No.10

kkkkkm

回答No.9はデータファイルを開いてから実行してください。

回答No.9

kkkkkm

[Summary3]のシート内の稼働率等の値の行(A2～AA2)を、1つのシートへコピペして追記。
が、どこのシートにコピーするのか不明ですのでお知らせください。
必ず行(A2～AA2)だけをコピーすると考えていいでしょうか。

以下のコードはデータの並び替えとコピペのテスト用です。

データファイルを並び替えして一塊ずつマクロファイルにコピペします。
確認のために一塊コピペするたびに一時停止します。
マクロの画面で上の方にある右三角のアイコンで実行してください。
一時停止して確認が出来たら再度右三角のアイコンをクリックしてください。
中止したい場合は右三角の右にある四角で止まります。

何が何に変更されたのか説明がないので「装置ID」が「共用部門装置ID」になったのだと考えています。

マクロファイルに記載して実行して下さい。
実際のデータファイル名に変更は変更してください。

Sub Test100()
Dim DataWb As Workbook
Dim MSheet As Worksheet
Dim i As Long, FRow As Long, ERow As Long
Dim IDCol As Long

Dim rc As VbMsgBoxResult
rc = MsgBox("マクロを実行しますか？", vbYesNo + vbQuestion, "■■■～～■■■")
If rc = vbYes Then
'next
Else
MsgBox ("処理を中止します"), vbCritical
Exit Sub
End If

Set DataWb = Workbooks("実際のデータファイル名に変更")
Set MSheet = ThisWorkbook.Sheets("カテゴリーログ")

Call M_Sort(DataWb)

Call M_Clear(MSheet)

With DataWb.Worksheets("結合_OK").ListObjects("テーブル1")
IDCol = .ListColumns("共用部門装置ID").DataBodyRange.Column
FRow = 2
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
Stop
Call M_Clear(MSheet)
End If
Next
End With

Set DataWb = Nothing
Set MSheet = Nothing

End Sub

Function M_Clear(ByRef MSheet As Worksheet)
With MSheet
.Activate '←2022/03/24追加
' .Range(.Cells(5, "A").End(xlDown), .Cells(5, "AK")).ClearContents
' ↑A5から下方向にA列のデータが続く最後の行までのA列からAK列までが対象
' データの最終行までにA列の途中に空白があると駄目
' もしくは
' ↓元のコードの範囲指定
.Range("A5:AK20004").ClearContents '←2022/03/24変更
.Range("A1").Select
End With
End Function

Function M_Sort(ByRef DataWb As Workbook)

With DataWb.Worksheets("結合_OK")
.ListObjects("テーブル1").Sort.SortFields.Clear
.ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=.Range("テーブル1[部署]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=.Range("テーブル1[グループ]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
.ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=.Range("テーブル1[共用部門装置ID]"), SortOn:=xlSortOnValues, Order:=xlAscending _
, DataOption:=xlSortNormal
.ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=.Range("テーブル1[利用日]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With .ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With

End Function

補足

本当に、大変お世話になります。
自動コピーのマクロの作成ありがとうございました。
手間が省けますし、急に資料の作成依頼が入っても、
このマクロを使わせて頂けたら大変助かります。

①本日、テスト用のマクロを試しました。
　全体の1/3程試しましたが、部署毎・グループ毎・装置毎にすべて正常にコピーされました。
　テストをする事は大切ですので、この後全てのデータについて、コピー状態の確認をします。
　※データ削除の .Range("A5:AK20004")は　→.Range("A5:AS20004")へ変更しました。

②『何が何に変更されたのか説明がないので「装置ID」が「共用部門装置ID」になったのだと考えています。』
　　　　　　↓
　　説明が不足してまして、申し訳ありません。お察しの通りす。
　　関連する項目について、前回、今回の項目名を記載させて頂きました。
【前回の項目名】
装置ID 装置名 ステーション グループ 利用日 開始時間 終了時間 利用時間 利用形態 ユーザーID
　　利用者 所属区分 所属機関 利用区分

【今回の項目名】
　共用部門装置ID 装置名 部署 グループ 利用日 開始時間 終了時間 利用時間 利用形態 "ユーザーID職員番号"
　　利用者 所属区分 所属機関 利用区分

③[Summary3]のシート内の稼働率等の値の行(A2～AA2)を、1つのシートへコピペして追記。
　が、どこのシートにコピーするのか不明ですのでお知らせください。必ず行(A2～AA2)だけをコピーすると考えていいでしょうか。
　　　　　　　↓
　・[Summary3]のシート内の稼働率等の値は可能でしたら,
　 新しいExcelのファイル(装置の稼働率-共用率_202204-202206.xlsx)
　 Sheet名＝(稼働率-共用率-202204-202206)へ保存出来たらと思います。
　 ※ファイル名やSheet名に日付は入らなくても問題ないです。

　・可能でしたら、上記の出力ファイルのシートの最上行に[Summary3]のデータの項目名、1行分を入れて頂き、それ以降は、必ず行(A2～AA2)だけをコピーするとして頂けたら、大変助かります。
何卒宜しくお願い致します。

回答No.8

kkkkkm

データ削除のコードが正常に動いた事了解しました。

並び替えの件ですが
データファイルの並べ替えのマクロを見ると質問にあるデータにはない項目があります。
また、部署、グループ、共用部門装置ID、利用日の順に並び替えされていますが、装置ID(共用部門装置IDの事でしょうか)はバラバラになっていると思います。手作業でコピペするときに装置IDを一塊としてとらえられたのでしょうか？

上から検査して装置IDが変化した時点で別の塊に移ったと考えますので、装置IDが上記の順番では装置IDの塊をとらえられません。

エラーの件ですが
> 　※最後に下記のエラーが出ましたが、問題無くマクロが動いて、
> 　　エラーメッセージ＝Microsoft Visual Basic for Applications　　X400

Workbooks.Open ThisWorkbook.Path & "\実際のマクロファイル名.xlsm"
この部分の「実際のマクロファイル名.xlsm」を実際のファイル名に書き直しているでしょうか。
「データチェック-稼働率求めマクロ.xlsm」が実際のファイル名だと思います。

エラーが出た場合、エラー箇所の見つけ方です。
エラーメッセージに「デバック」があればそれをクリックしてください。
エラーの行が黄色で選択されてます。
「デバッグ」が出ていない場合
コードの画面で
Sub Test()からEnd Subの範囲のどこかをクリックしして
F8キーを押すと一行ずつ実行されます。
エラーになるとエラーのメッセージが出ますから「デバッグ」をクリックするとエラーの行が黄色で選択されてます。
その部分を教えてください。

なお、コードの中に
For i = 1 To 250
色々なコード
Next
(1と250は数値ではない場合があります、ForからNextで囲まれているようなところ)
のようなところがあるとF8で一行ずつ実行すると、上記の場合250回色々なコードを一行ずつ実行するのでとてつもなく時間がかかりますからその場合は別の方法をとります。別の方法は必要になったときにお知らせします。

補足

大変お世話になっております。早速のご教示大変有難いことです。
ご質問に返答させて頂きました。宜しくお願い致します。

①『ID(共用部門装置IDの事でしょうか)はバラバラになっていると思います』
　　　　　　↓
　申し訳ありません。今回の項目名は、最初の質問文に書いた項目名と違っております。最終は今回の項目でテストをする予定でおります。項目名は若干違っていますが、項目の列は45列や項目の順番は今回も同じです。

②『並べ替えで、装置IDはバラバラになっていると思います』
　　　　　　↓
　　各装置は、部署やグループ内で単体扱いで管理運用されています。装置は部署やグループ内で共用性がない為、この並び替えで、装置順に並べる事が出来ています。

③『上から検査して装置IDが変化した時点で別の塊に移ったと考えます』
　　　　　　↓
　　このやり方で良いはずです。

④『エラーの件ですが、実際のファイル名に書き直しているでしょうか』
　　　　　　↓
　マクロ内を実際のマクロ名にしたら、エラーは出なくなり、正常に『ステーション_グループ_装置ID_装置名.xlsx』の名前で保存できました。
　エラーが出た時の詳細な説明ありがとうございました。

回答No.7

kkkkkm

削除のコードを見ると、カテゴリーログのA5から削除してますが、質問ではA4から値貼り付けとなっています。ですので、No.2のコードは4行目のデータをもとにファイル名を作成していますので、A5から貼り付けた場合ファイル名が違ってきます。

かなりの回数繰り返しますから、セル範囲選択時のSelectは省いていいと思いますので
データ削除()の削除実行部分は、以下のように変更しても大丈夫だと思います。
一度変更してみて試してみてください。

'■ (Logデータを削除します。20000行まで。)
With Sheets("カテゴリーログ")
.Select '←2022/03/24追加
' .Range(.Cells(5, "A").End(xlDown), .Cells(5, "AK")).ClearContents
' ↑A5から下方向にA列のデータが続く最後の行までのA列からAK列までが対象
' データの最終行までにA列の途中に空白があると駄目
' もしくは
' ↓元のコードの範囲指定
.Range("A5:AK20004").ClearContents '←2022/03/24変更
.Range("A1").Select
End With

補足

熱心にご教示頂き、本当に心より感謝致します。
①②③を実施しましたので、ご報告致します。
①削除マクロを、ご教示頂いた通りに修正してみました。
　データの列がAO列まであるので、AK→AOへ修正しています。
　※問題無く、カテゴリーログシート内のデータは削除出来ました。
・マクロ名＝『データ削除』
Option Explicit

Sub データ削除()
' ====================================
' データ削除 Macro
' シート「カテゴリーログ」のデータを全て削除する。
' 2022/03/24更新／
' ====================================

'■（ダイアログボックスを表示して、実行するか否か確認する）
Dim rc As VbMsgBoxResult
rc = MsgBox("マクロを実行しますか？", vbYesNo + vbQuestion, "■■■～Logデータを削除します～■■■")
If rc = vbYes Then
'next
Else
MsgBox ("処理を中止します"), vbCritical
End
End If

'■ (Logデータを削除します。20000行まで。)
With Sheets("カテゴリーログ")
.Select '←2022/03/24追加
' .Range(.Cells(5, "A").End(xlDown), .Cells(5, "AK")).ClearContents
' ↑A5から下方向にA列のデータが続く最後の行までのA列からAK列までが対象
' データの最終行までにA列の途中に空白があると駄目
' もしくは
' ↓元のコードの範囲指定
.Range("A5:AO20004").ClearContents '←2022/03/24変更
.Range("A1").Select
End With

End Sub

②稼働率を求めるマクロ(データチェック-稼働率求めマクロ.xlsm)に、ご教示頂いた下記のマクロを追加しました。
　※最後に下記のエラーが出ましたが、問題無くマクロが動いて、
　　エラーメッセージ＝Microsoft Visual Basic for Applications　　X400
　　『ステーション_グループ_装置ID_装置名.xlsx』の名前でマクロと同じホルダーへ保存できました。
・マクロ名＝ThisWorkbook.Test
Option Explicit

Sub Test()
Dim wb As Workbook
Dim NewBookName As String

Set wb = ThisWorkbook
With Worksheets("カテゴリーログ")
NewBookName = .Range("C5").Value & "_" & .Range("D5").Value & "_" & .Range("A5").Value & "_" & .Range("B5").Value & ".xlsx"
End With

'マクロ無しのブックに保存できないというメッセージが出ますがOkしてください。
wb.SaveAs ThisWorkbook.Path & "\" & NewBookName, FileFormat:=xlOpenXMLWorkbook
MsgBox "ファイル名を「 " & NewBookName & " 」として保存しました", vbInformation
'↓元のマクロブックを開きます　ブック名は実際のブック名にしてください
Workbooks.Open ThisWorkbook.Path & "\実際のマクロファイル名.xlsm"

wb.Close '←名前を変更し保存したブックを閉じたくない場合はここを削除

Set wb = Nothing

End Sub

③データファイルの並べ替えのマクロの記録は下記の通りです。
Sub データの並び替え()
'
' データの並び替え Macro
'

'
ActiveWorkbook.Worksheets("結合_OK").ListObjects("テーブル1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("結合_OK").ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=Range("テーブル1[部署]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("結合_OK").ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=Range("テーブル1[グループ]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("結合_OK").ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=Range("テーブル1[共用部門装置ID]"), SortOn:=xlSortOnValues, Order:=xlAscending _
, DataOption:=xlSortNormal
ActiveWorkbook.Worksheets("結合_OK").ListObjects("テーブル1").Sort.SortFields.Add2 _
Key:=Range("テーブル1[利用日]"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("結合_OK").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub