別ファイルへのデータ出力とタスクへマクロ登録

質問

大変お世話になっております。
ホルダーに保存した複数データ(Excel形式)の指定した列のデータを1つの出力ファイルへ追記する為に、EXCELのマクロを使用しております。マクロは手動で起動させています。
今回、ご教示を頂きたい事は、以下の2点になります。
①出力データは、マクロファイル内のシートへ保存する設定にしていますが、別ホルダーの別ファイルの別シートへデータを出力出来るようにし、出力は1行おきに色を付けたい。

②更に、マクロは手動で起動させていますが、タスクマネージャーに入れてマクロファイルを登録し、決められた時間に出力ファイルを作成したい。

マクロは全くの初心者で、どの部分を修正すれば、
①が実行出来るようになるのか、色々とネットで検索しながら、
スクリプトを変更して見ましたが、できませんでした。

先ずは、①についてご教示頂けないでしょうか。
下記コードはマクロ内のシートへデータ出力である事はわかるのですが、どのように変更すべきなのかわからず大変困っております。
　　　　Set O = ThisWorkbook.ActiveSheet

以下に、現在使用しているマクロを記載させて頂きました。　
Sub Macro1()
Dim O As Worksheet
Dim FileName As String
Dim ROut As Long
Dim REnd As Long

Cells(1, "A") = "個人番号"
Cells(1, "A").EntireColumn.ColumnWidth = 15

Cells(1, "B") = "職員番号"
Cells(1, "B").EntireColumn.ColumnWidth = 15

Cells(1, "C") = "氏名"
Cells(1, "C").EntireColumn.ColumnWidth = 15

Cells(1, "D") = "所属/拠点"
Cells(1, "D").EntireColumn.ColumnWidth = 15

Cells(1, "E") = "所属/グループ"
Cells(1, "E").EntireColumn.ColumnWidth = 15

Cells(1, "F") = "役職"
Cells(1, "F").EntireColumn.ColumnWidth = 15

Cells(1, "G") = "開始年月日"
Cells(1, "G").EntireColumn.ColumnWidth = 15

Cells(1, "H") = "終了年月日"
Cells(1, "H").EntireColumn.ColumnWidth = 15

Cells(1, "I") = "申告"
Cells(1, "I").EntireColumn.ColumnWidth = 15

Cells(1, "J") = "判定1"
Cells(1, "J").EntireColumn.ColumnWidth = 15

Cells(1, "K") = "判定2"
Cells(1, "K").EntireColumn.ColumnWidth = 15

Cells(1, "L") = "判定3"
Cells(1, "L").EntireColumn.ColumnWidth = 15

Cells(1, "M") = "判定4"
Cells(1, "M").EntireColumn.ColumnWidth = 15

Cells(1, "N") = "判定5"
Cells(1, "N").EntireColumn.ColumnWidth = 15
'
Set O = ThisWorkbook.ActiveSheet
FileName = Dir(ThisWorkbook.Path & "\参加者_*.xlsx")
Range("A2:N" & Rows.Count).ClearContents
ActiveSheet.CheckBoxes.Delete
ROut = 2
Application.ScreenUpdating = False
'
Do While FileName > ""
Workbooks.Open ThisWorkbook.Path & "\" & FileName, False, True
FileName = Replace(FileName, ".xlsx", "")
'
If ROut < 8 Then
Rows("1:" & 8 - ROut).Delete
ElseIf ROut > 8 Then
Rows("8:" & ROut - 1).Insert
End If
REnd = Cells(Rows.Count, "C").End(xlUp).Row
O.Range("A" & ROut, "A" & REnd) = Mid(FileName, 7)
Range("B" & ROut, "H" & REnd).Copy O.Range("B" & ROut)

Range("N" & ROut, "N" & REnd).Copy O.Range("I" & ROut)
Range("Q" & ROut, "U" & REnd).Copy O.Range("J" & ROut)

ROut = REnd + 1
ActiveWorkbook.Close False
FileName = Dir
Loop

' Range("A1").Select
' Range("A1").CurrentRegion.ClearFormats
' ActiveSheet.ListObjects.Add SourceType:=xlSrcRange, Source:=ActiveSheet.Range("A1").CurrentRegion

'数値へ変換
Range("B:B").Value = Range("B:B").Value
Range("B:B").Replace What:=vbTab, Replacement:=""

MsgBox ("完了です")
End Sub

回答No.10

HohoPapa · ベストアンサー

>ログファイルを上書きする設定
以下のように、ログへの出力開始直前に、
ログファイルを削除するコードとしてみました。

Option Explicit

'出力先のフォルダーは事前に作成されている前提
'実行ログは、マクロブックと同じフォルダーにマクロが作成する。
'実行ログは常に追記。必要に応じて、手動で行削除、あるいはファイルの削除を行う。

Sub Sample()

　Const colCount = 13

　Dim PutDir　　As String
　Dim PutFileName As String
　Dim PutFullPath As String
　Dim GetDir As String

　Dim B As Workbook
　Dim O As Worksheet
　Dim FileName As String
　Dim ROut As Long
　Dim REnd As Long

　Kill ThisWorkbook.Path & "\MyLog.txt"　　'Logファイル削除
　LogPut "処理開始"

　'GetDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\データ"
　GetDir = "D:\TestDir"
　'PutDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\出力ファイル"
　PutDir = "D:\TestDir"
　PutFileName = "2023-参加者リスト纏_" & Format(Now, "YYYYMMDDHHNN") & ".xlsx"
　PutFullPath = PutDir & "\" & PutFileName

　Set B = Workbooks.Add '出力先ブックを新規オープン
　Set O = B.Sheets(1)　　　　'出力先シートを定義

以下省略

お礼

大変お世話になっております。
ログファイル削除のコードについて、ご教示、誠に有難うございました。
『kill』についても、昨夜色々と試していましたが、正しいコードの記載が出来なくて諦めました。
今朝(7/15)、ネットで調べて下記を試した所、上手くログファイルの削除が出来ました。
Sub DeleteFile()
Dim fso As New Scripting.FileSystemObject
fso.DeleteFile ("C:\Users\Owner\Desktop\10_2023-参画者リスト\スクリプト\MyLog.txt")
Set fso = Nothing
End Sub
しかしながら、ご教示頂いたコードの方がスッキリして良いので、早速試しました。
ログファイルは一旦削除されて、再度ログファイルに書き込みが出来た事を確認しました。
長期に渡り面倒を見て下さいまして、本当に有難うございました。
これから、次の段階(マクロの自動実行)へ進みます。
上記についても、これから色々と調べて試して行きます。
躓いた時は、またOKWAVEに質問をさせて頂きます。
HohoPapaさんのご教示のお陰で、マクロのコードについて、仕組みが少々ですが分かるようになりました。
ありがとうございました。

回答No.9

HohoPapa

>先頭に『'』の文字が入っていたり
この対応をしてみました。
なお、もし、タブ、先頭に『'』、
この条件以外で、
数字以外の文字が含まれている場合は、ゼロを埋めるようにしました。

エラーを表示して異常終了することも考えましたが
無人運転を予定しているらしいことから
エラーとはならないようにしました。

先頭から一部を省略

'　'数値へ変換
'　Range("B:B").Value = Range("B:B").Value
'　Range("B:B").Replace What:=vbTab, Replacement:=""

　'最終行を取得し、範囲をテーブル化し、文字フォントを設定
　REnd = O.Cells(Rows.Count, "C").End(xlUp).Row

　Dim tgRane As Range
　Dim i As Long
　With O
　　Set tgRane = Range(.Cells(1, 1), .Cells(REnd, colCount))
　　.Range("B:B").Replace What:=vbTab, Replacement:=""
　　.Range("B:B").NumberFormatLocal = "G/標準"
　　For i = 2 To REnd
　　　.Cells(i, 2).Value = Val(.Cells(i, 2).Value) * 1
　　Next i
　End With
　With tgRane
　　O.ListObjects.Add(xlSrcRange, tgRane, , xlYes).Name = "テーブル1"
　　.Font.Name = "游ゴシック"
　　.Font.Size = 10
　　.HorizontalAlignment = xlRight '　←追加した行
　End With

　'集約したブックを保存して閉じる
　Application.DisplayAlerts = False
　B.SaveAs FileName:=PutFullPath
　B.Close
　Application.DisplayAlerts = True

　LogPut "処理終了"
　endjob_Auto

End Sub

以下省略

お礼

早速のご教示、有難うございました。
最後まで面倒を見て頂きまして、感謝する共に大変恐縮です。
遂に自分の望む通りに出力させる事が出来ました。
この後、最終チェックの後に完了のお知らせをいたしますので、少々お待ち下さい。
取り急ぎ　御礼まで。

補足

大変お世話になっております。
大変お手数ですが、もう一つご教示頂けないでしょうか？
ログファイルへの出力ですが、
今現在はテキストファイルへ追加の設定になっておりますが、ログファイルを上書きする設定についても教えて頂きたいです。
本日最終テストをしまして、出力データに問題が無い事を確認しました。ログファイルについては上書きにする設定でも試して見たくなりました。わがままを言いまして申し訳ありません。

回答No.8

HohoPapa

こんなコードでいかがでしょうか。
Ｂ列のVbTabをNullに置き換え、
B列の書式を"G/標準"に変更しました。

先頭から一部を省略

'　　'数値へ変換
'　　Range("B:B").Value = Range("B:B").Value
'　　Range("B:B").Replace What:=vbTab, Replacement:=""

　　'最終行を取得し、範囲をテーブル化し、文字フォントを設定
　　REnd = O.Cells(Rows.Count, "C").End(xlUp).Row

　　Dim tgRane As Range
　　With O
　　　　Set tgRane = Range(.Cells(1, 1), .Cells(REnd, colCount))
　　　　.Range("B:B").Replace What:=vbTab, Replacement:=""
　　　　.Range("B:B").NumberFormatLocal = "G/標準"
　　End With
　　With tgRane
　　　　O.ListObjects.Add(xlSrcRange, tgRane, , xlYes).Name = "テーブル1"
　　　　.Font.Name = "游ゴシック"
　　　　.Font.Size = 10
　　　　.HorizontalAlignment = xlRight '　←追加した行
　　End With

　　'集約したブックを保存して閉じる
　　Application.DisplayAlerts = False
　　B.SaveAs FileName:=PutFullPath
　　B.Close
　　Application.DisplayAlerts = True

　　LogPut "処理終了"
　　endjob_Auto

End Sub

以下省略

お礼

大変お世話になっております。
昨夜(7/14)、ログファイルの上書きの設定について質問させて頂きましたが、下記、コードをマクロに追記実行した結果、MyLog.txtは一旦削除されてから、再度作成されるようになりました。
DeleteFile

Sub DeleteFile()
Dim fso As New Scripting.FileSystemObject
fso.DeleteFile ("C:\Users\Owner\Desktop\参画者リスト\スクリプト\MyLog.txt")
Set fso = Nothing
End Sub
マクロのコード(VBA)の仕組みが少し見えてきました。
今回のスレッド(質問)はこれで完了としまして、
ログファイルの設定について気になるような時は、別スレッドで質問をするように致します。
これから、次の段階(自動起動)へ進める事にします。
ご丁寧にご教示頂きまして、心より感謝申し上げます。
本当にありがとうございました。

補足

大変お世話になっております。
早速のご教示ありがとうございました。
早速、試した結果、元データB列の一部の値には
先頭に『'』の文字が入っていたり、数値が文字列として保存されている事がわかりました。これらは出力データでも、『001045』のように記載されて、値の手前の『0』がそのままついてしまっていました。
上記の全ての元データは、エラーエンジケーター(セル左上に▼の印)がついていて、エラーが出ているセルをクリックし、『！』を選択すると、『このセルにある数値がテキスト形式またはアポストロフィで始まっています』のメッセージが出ました。
これらの元データを、手動で『！』▼から『数値に変換する』を選択すると、数値に変換出来ました。
文字形式を数値へ変換すると、値の手前の『’』を削除するコートを追加すべきでしょうか？
本当に、お手数をお掛けしてしまい大変申し訳ありませんが、これらを対処するコードをご存知でしたら、ご教示を頂けますます大変助かります。
以上　どうぞよろしくお願いします。

回答No.7

HohoPapa

>元データは数値、文字、タブが入っていたりしている
ここをしっかり読まずにコードを提示してしまいました。

タブが含まれているのは理解しましたが、
数字以外の文字が含まれているということでしょうか。

サンプル的に、その文字列例を提示してみてください。

補足

大変お世話になっております。
ご返信を頂きまして、誠に有難うございます。
以下のような説明でお分かりになればよいのですが。

B列[職員番号]は元データも出力データも、書式設定が下記の3パターンで記載されています。
-------------
001141←表示形式＝『その他』、ロケール＝ロシア語
-------------
▼　　011687←表示形式＝『文字列』、▼はセルの向左上についています。
-------------
　　　 21315←表示形式＝『標準』
-------------
大変恐縮ですが、対処方法お分かりでしたら、ご教示頂けますと大変助かります。

回答No.6

HohoPapa

こんなコードでいかがでしょうか。

先頭から一部を省略

'　'数値へ変換
'　Range("B:B").Value = Range("B:B").Value
'　Range("B:B").Replace What:=vbTab, Replacement:=""

　'最終行を取得し、範囲をテーブル化し、文字フォントを設定
　REnd = O.Cells(Rows.Count, "C").End(xlUp).Row

　Dim tgRane As Range
　With O
　　Set tgRane = Range(.Cells(1, 1), .Cells(REnd, colCount))
　　.Range("B:B").NumberFormatLocal = "G/標準"　'B列を編集

　End With
　With tgRane
　　O.ListObjects.Add(xlSrcRange, tgRane, , xlYes).Name = "テーブル1"
　　.Font.Name = "游ゴシック"
　　.Font.Size = 10
　　.HorizontalAlignment = xlRight '　←追加した行
　End With

　'集約したブックを保存して閉じる
　Application.DisplayAlerts = False
　B.SaveAs FileName:=PutFullPath
　B.Close
　Application.DisplayAlerts = True

　LogPut "処理終了"
　endjob_Auto

End Sub

以下省略

回答No.5

HohoPapa

>出力ファイルの文字フォントを『遊ゴシック』フォントサイズ『10』で記載させたい
>出力データをテーブル形式にして、1行毎に色を変える
組み込んでみました。

>①は、不要なので、削除しました。←外しても問題有りませんでした。
コメントアウトしました。

>②は、理解出来ずに使用しているコードで、
残しました。

>自動実行はそんなに簡単には行かないかもしれませんね
可能ですが、十分な期間、手動で実行し
安定稼働し、かつ、
環境や要求が変わったときのことをイメージできてからにしたほうがいいと思います。
この部分は、課題が今までと異なるので、
別なスレッドとしてください。

Option Explicit

'出力先のフォルダーは事前に作成されている前提
'実行ログは、マクロブックと同じフォルダーにマクロが作成する。
'実行ログは常に追記。必要に応じて、手動で行削除、あるいはファイルの削除を行う。

Sub Sample()

　Const colCount = 13

　Dim PutDir　As String
　Dim PutFileName As String
　Dim PutFullPath As String
　Dim GetDir As String

　Dim B As Workbook
　Dim O As Worksheet
　Dim FileName As String
　Dim ROut As Long
　Dim REnd As Long
　Dim tgRane As Range

　LogPut "処理開始"

　'GetDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\データ"
　GetDir = "D:\TestDir"
　'PutDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\出力ファイル"
　PutDir = "D:\TestDir"
　PutFileName = "2023-参加者リスト纏_" & Format(Now, "YYYYMMDDHHNN") & ".xlsx"
　PutFullPath = PutDir & "\" & PutFileName

　Set B = Workbooks.Add '出力先ブックを新規オープン
　Set O = B.Sheets(1)　　'出力先シートを定義

　'出力先、1行目の書き込みと列幅を設定
　With O
　　.Cells(1, "A") = "個人番号"
　　.Cells(1, "A").EntireColumn.ColumnWidth = 15
　　.Cells(1, "B") = "職員番号"
　　.Cells(1, "B").EntireColumn.ColumnWidth = 15
　　.Cells(1, "C") = "氏名"
　　.Cells(1, "C").EntireColumn.ColumnWidth = 15
　　.Cells(1, "D") = "所属/拠点"
　　.Cells(1, "D").EntireColumn.ColumnWidth = 15
　　.Cells(1, "E") = "所属/グループ"
　　.Cells(1, "E").EntireColumn.ColumnWidth = 15
　　.Cells(1, "F") = "役職"
　　.Cells(1, "F").EntireColumn.ColumnWidth = 15
　　.Cells(1, "G") = "開始年月日"
　　.Cells(1, "G").EntireColumn.ColumnWidth = 15
　　.Cells(1, "H") = "終了年月日"
　　.Cells(1, "H").EntireColumn.ColumnWidth = 15
　　.Cells(1, "I") = "申告"
　　.Cells(1, "I").EntireColumn.ColumnWidth = 15
　　.Cells(1, "J") = "判定1"
　　.Cells(1, "J").EntireColumn.ColumnWidth = 15
　　.Cells(1, "K") = "判定2"
　　.Cells(1, "K").EntireColumn.ColumnWidth = 15
　　.Cells(1, "L") = "判定3"
　　.Cells(1, "L").EntireColumn.ColumnWidth = 15
　　.Cells(1, "M") = "判定4"
　　.Cells(1, "M").EntireColumn.ColumnWidth = 15
　　.Cells(1, "N") = "判定5"
　　.Cells(1, "N").EntireColumn.ColumnWidth = 15
　End With

　FileName = Dir(GetDir & "\参加者_*.xlsx")
　'Range("A2:N" & Rows.Count).ClearContents
　ActiveSheet.CheckBoxes.Delete

　ROut = 2
　Application.ScreenUpdating = False

　Do While FileName > ""
　　Workbooks.Open GetDir & "\" & FileName, False, True
　　FileName = Replace(FileName, ".xlsx", "")

　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If

　　REnd = Cells(Rows.Count, "C").End(xlUp).Row
　　O.Range("A" & ROut, "A" & REnd) = Mid(FileName, 7)
　　Range("B" & ROut, "H" & REnd).Copy O.Range("B" & ROut)
　　Range("N" & ROut, "N" & REnd).Copy O.Range("I" & ROut)
　　Range("Q" & ROut, "U" & REnd).Copy O.Range("J" & ROut)

　　ROut = REnd + 1
　　ActiveWorkbook.Close False
　　LogPut FileName
　　FileName = Dir
　Loop

　'数値へ変換
　Range("B:B").Value = Range("B:B").Value
　Range("B:B").Replace What:=vbTab, Replacement:=""

　'最終行を取得し、範囲をテーブル化し、文字フォントを設定
　REnd = O.Cells(Rows.Count, "C").End(xlUp).Row

　With O
　　Set tgRane = Range(.Cells(1, 1), .Cells(REnd, colCount))
　End With
　With tgRane
　　O.ListObjects.Add(xlSrcRange, tgRane, , xlYes).Name = "テーブル1"
　　.Font.Name = "游ゴシック"
　　.Font.Size = 10
　End With

　'集約したブックを保存して閉じる
　Application.DisplayAlerts = False
　B.SaveAs FileName:=PutFullPath
　B.Close
　Application.DisplayAlerts = True

　LogPut "処理終了"
　endjob_Auto

End Sub

'//------ログ出力処理
=====以下省略

補足

大変お世話になっております。
続けてご教示を頂けて、本当にありがとうございました。
お陰様で、ほぼ希望通りの出力が出来るようになりました。

1点程、助けて頂きたい箇所があります。
B列[職員番号]は、最大で5桁の数値(手前に『0』無し)へ変換したいのですが、下記コードについてネットを見たりして色々試して見たのですが、上手く手前の『0』を無くした数値への変換が出来ませんでした。
このB列の値は、別ファイルでマスターデータとして使用する為、フォーマット通りの数値にしなければなりません。

元データは数値、文字、タブが入っていたりしている為、下記コードを使用していますが、
'数値へ変換
　Range("B:B").Value = Range("B:B").Value
　Range("B:B").Replace What:=vbTab, Replacement:=""

出力ファイルのＢ列を確認すると、①、②のような値が殆どでした。
①前に『0』が入っていて、書式設定は、分類＝その他、種類＝最上列の設定(難しい文字で記載不可能）：ロシア語になっている。
②セルの向左上に緑▼の印がついていて、セルの書式設定は『文字列』になっている。

記載の右詰めは、ご教示頂いたコードに1行を追加して出来ました。

'最終行を取得し、範囲をテーブル化し、文字フォントを設定
REnd = O.Cells(Rows.Count, "C").End(xlUp).Row

With O
Set tgRane = Range(.Cells(1, 1), .Cells(REnd, colCount))

End With
With tgRane
O.ListObjects.Add(xlSrcRange, tgRane, , xlYes).Name = "テーブル1"
.Font.Name = "游ゴシック"
.Font.Size = 10
.HorizontalAlignment = xlRight　←追加した行
End With

数値への変換が上手く行けば、これで完了として最終テストを実施したいと思います。
大変恐縮ですが、お分かりでしたら、ご教示頂けますと大変助かります。

回答No.4

HohoPapa

後記のようなコードとしてみました。
マクロを実行すると、最後のところで、マクロブック自身も閉じるようにしました。
また、
実行ログをマクロブック配置フォルダーに作成しますので
実行したかどうかや、どのファイルたちを処理したかがわかるようにしました。

マクロブックの配置個所は問いません。
マクロの実行可能な任意のフォルダーに配置して実行してください。

また、下記コード部分は直して使ってください。

　'GetDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\データ"
　GetDir = "D:\TestDir"
　'PutDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\出力ファイル"
　PutDir = "D:\TestDir"

つまり、2,4行目をコメントアウトし、1,3行目を生かし、修正してください。

Option Explicit

'出力先のフォルダーは事前に作成されている前提
'実行ログは、マクロブックと同じフォルダーにマクロが作成する。
'実行ログは常に追記。必要に応じて、手動で行削除、あるいはファイルの削除を行う。

Sub Sample()

　Dim PutDir　As String
　Dim PutFileName As String
　Dim PutFullPath As String
　Dim GetDir As String

　Dim B As Workbook
　Dim O As Worksheet
　Dim FileName As String
　Dim ROut As Long
　Dim REnd As Long

　LogPut "処理開始"

　'GetDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\データ"
　GetDir = "D:\TestDir"
　'PutDir = "C:\Users\Owner\Desktop\10_2023-参加者リスト\出力ファイル"
　PutDir = "D:\TestDir"
　PutFileName = "2023-参加者リスト纏_" & Format(Now, "YYYYMMDDHHNN") & ".xlsx"
　PutFullPath = PutDir & "\" & PutFileName

　Set B = Workbooks.Add '出力先ブックを新規オープン
　Set O = B.Sheets(1)　　'出力先シートを定義

　'出力先、1行目の書き込みと列幅を設定
　With O
　　.Cells(1, "A") = "個人番号"
　　.Cells(1, "A").EntireColumn.ColumnWidth = 15
　　.Cells(1, "B") = "職員番号"
　　.Cells(1, "B").EntireColumn.ColumnWidth = 15
　　.Cells(1, "C") = "氏名"
　　.Cells(1, "C").EntireColumn.ColumnWidth = 15
　　.Cells(1, "D") = "所属/拠点"
　　.Cells(1, "D").EntireColumn.ColumnWidth = 15
　　.Cells(1, "E") = "所属/グループ"
　　.Cells(1, "E").EntireColumn.ColumnWidth = 15
　　.Cells(1, "F") = "役職"
　　.Cells(1, "F").EntireColumn.ColumnWidth = 15
　　.Cells(1, "G") = "開始年月日"
　　.Cells(1, "G").EntireColumn.ColumnWidth = 15
　　.Cells(1, "H") = "終了年月日"
　　.Cells(1, "H").EntireColumn.ColumnWidth = 15
　　.Cells(1, "I") = "申告"
　　.Cells(1, "I").EntireColumn.ColumnWidth = 15
　　.Cells(1, "J") = "判定1"
　　.Cells(1, "J").EntireColumn.ColumnWidth = 15
　　.Cells(1, "K") = "判定2"
　　.Cells(1, "K").EntireColumn.ColumnWidth = 15
　　.Cells(1, "L") = "判定3"
　　.Cells(1, "L").EntireColumn.ColumnWidth = 15
　　.Cells(1, "M") = "判定4"
　　.Cells(1, "M").EntireColumn.ColumnWidth = 15
　　.Cells(1, "N") = "判定5"
　　.Cells(1, "N").EntireColumn.ColumnWidth = 15
　End With

　FileName = Dir(GetDir & "\参加者_*.xlsx")
　'Range("A2:N" & Rows.Count).ClearContents
　ActiveSheet.CheckBoxes.Delete

　ROut = 2
　Application.ScreenUpdating = False

　Do While FileName > ""
　　Workbooks.Open GetDir & "\" & FileName, False, True
　　FileName = Replace(FileName, ".xlsx", "")

　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If

　　REnd = Cells(Rows.Count, "C").End(xlUp).Row
　　O.Range("A" & ROut, "A" & REnd) = Mid(FileName, 7)
　　Range("B" & ROut, "H" & REnd).Copy O.Range("B" & ROut)
　　Range("N" & ROut, "N" & REnd).Copy O.Range("I" & ROut)
　　Range("Q" & ROut, "U" & REnd).Copy O.Range("J" & ROut)

　　ROut = REnd + 1
　　ActiveWorkbook.Close False
　　LogPut FileName
　　FileName = Dir
　Loop

　 ' Range("A1").Select
　 ' Range("A1").CurrentRegion.ClearFormats
　 ' ActiveSheet.ListObjects.Add SourceType:=xlSrcRange, Source:=ActiveSheet.Range("A1").CurrentRegion

　'数値へ変換
　Range("B:B").Value = Range("B:B").Value
　Range("B:B").Replace What:=vbTab, Replacement:=""

　'集約したブックを保存して閉じる
　Application.DisplayAlerts = False
　B.SaveAs FileName:=PutFullPath
　B.Close
　Application.DisplayAlerts = True

　LogPut "処理終了"
　endjob_Auto

End Sub

'//------ログ出力処理
Sub LogPut(MyText As String)
　Open ThisWorkbook.Path & "\MyLog.txt" For Append As #1
　Print #1, Now & Chr(9) & MyText
　Close #1
End Sub

'//------終了処理
Sub endjob_Auto()
　ThisWorkbook.Activate
　If Application.Workbooks.Count = 1 Then
　　Application.DisplayAlerts = False
　　'ThisWorkbook.Saved = True
　　Application.Quit
　Else
　　Application.DisplayAlerts = False
　　ThisWorkbook.Close　'SaveChanges:=False
　End If
End Sub

補足

大変お世話になっております。
マクロの更新ありがとうございました。
①、②共に希望通りに、マクロが動きました。大変感謝致します。
約1300個のデータを出力ファイルへ出力するのに、4分程で作業を完了する事が出来ました。
また、ログファイルを用意して頂きましたので、確認が分かり易くなりました。

五月雨式で大変恐縮なのですが、
出力ファイルの文字フォントを『遊ゴシック』フォントサイズ『10』で記載させたいのですが、コードに記載する事は可能なのでしょうか？

また、出力データをテーブル形式にして、1行毎に色を変える事をコードで記載する方法がお分かりでしたら、ご教示頂けますと大変助かります。
ネットで調べると、下記のようなコードを入れると良いそうですが、ご教示頂いているコードのどの部分に入れて良いのか分かりませんでした。
シートオブジェクト.ListObjects.Add(SourceType, Source, LinkSource, XlListObjectHasHeaders, Destination, TableStyleName)

これらが実現出来ましたら、このマクロを自動実行の設定にして、windowsのタスクマネージャーへ登録すれば、
良いのかなとか単純に考えております。
自動実行はそんなに簡単には行かないかもしれませんね。

ご指摘を頂いておりました下記2点ですが、
①は、不要なので、削除しました。←外しても問題有りませんでした。
②は、理解出来ずに使用しているコードで、
元データは必ず8行目からデータが入っています。
このコードをメッセージにして、マクロを起動すると、
出力ファイルが正常に作成されませんでしたので、元に戻しました。

①ActiveSheet.CheckBoxes.Delete

②　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If
このコードで
複写元のデータの行数が8行未満かどうかで動作が異なるようです。

回答No.3

HohoPapa

#2です。早速間違えているので差し替えます。

可能な限り、示されたコードを生かすコードとしてみました。

なお、なにやら、

　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If

このコードで
複写元のデータの行数が8行未満かどうかで動作が異なるようです。

また、

　ActiveSheet.CheckBoxes.Delete

これが何をやっているのかよくわからないです。
マクロブックのActiveSheetにCheckBoxesがあれば削除しているようです。
CheckBoxesが無ければ、単に空振りする動作です。

Option Explicit

Sub Macro2()

　Const PutBookName = "D:\TestDir\Sample.xlsx"

　Dim B As Workbook
　Dim O As Worksheet
　Dim FileName As String
　Dim ROut As Long
　Dim REnd As Long

　Set B = Workbooks.Add '出力先ブックを新規オープン
　Set O = B.Sheets(1)　　'出力先シートを定義

　'出力先、1行目の書き込みと列幅を設定
　With O
　　.Cells(1, "A") = "個人番号"
　　.Cells(1, "A").EntireColumn.ColumnWidth = 15
　　.Cells(1, "B") = "職員番号"
　　.Cells(1, "B").EntireColumn.ColumnWidth = 15
　　.Cells(1, "C") = "氏名"
　　.Cells(1, "C").EntireColumn.ColumnWidth = 15
　　.Cells(1, "D") = "所属/拠点"
　　.Cells(1, "D").EntireColumn.ColumnWidth = 15
　　.Cells(1, "E") = "所属/グループ"
　　.Cells(1, "E").EntireColumn.ColumnWidth = 15
　　.Cells(1, "F") = "役職"
　　.Cells(1, "F").EntireColumn.ColumnWidth = 15
　　.Cells(1, "G") = "開始年月日"
　　.Cells(1, "G").EntireColumn.ColumnWidth = 15
　　.Cells(1, "H") = "終了年月日"
　　.Cells(1, "H").EntireColumn.ColumnWidth = 15
　　.Cells(1, "I") = "申告"
　　.Cells(1, "I").EntireColumn.ColumnWidth = 15
　　.Cells(1, "J") = "判定1"
　　.Cells(1, "J").EntireColumn.ColumnWidth = 15
　　.Cells(1, "K") = "判定2"
　　.Cells(1, "K").EntireColumn.ColumnWidth = 15
　　.Cells(1, "L") = "判定3"
　　.Cells(1, "L").EntireColumn.ColumnWidth = 15
　　.Cells(1, "M") = "判定4"
　　.Cells(1, "M").EntireColumn.ColumnWidth = 15
　　.Cells(1, "N") = "判定5"
　　.Cells(1, "N").EntireColumn.ColumnWidth = 15
　End With

　FileName = Dir(ThisWorkbook.Path & "\参加者_*.xlsx")
　'Range("A2:N" & Rows.Count).ClearContents
　ActiveSheet.CheckBoxes.Delete

　ROut = 2
　Application.ScreenUpdating = False

　Do While FileName > ""
　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, False, True
　　FileName = Replace(FileName, ".xlsx", "")

　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If

　　REnd = Cells(Rows.Count, "C").End(xlUp).Row
　　O.Range("A" & ROut, "A" & REnd) = Mid(FileName, 7)
　　Range("B" & ROut, "H" & REnd).Copy O.Range("B" & ROut)
　　Range("N" & ROut, "N" & REnd).Copy O.Range("I" & ROut)
　　Range("Q" & ROut, "U" & REnd).Copy O.Range("J" & ROut)

　　ROut = REnd + 1
　　ActiveWorkbook.Close False
　　FileName = Dir
　Loop

　 ' Range("A1").Select
　 ' Range("A1").CurrentRegion.ClearFormats
　 ' ActiveSheet.ListObjects.Add SourceType:=xlSrcRange, Source:=ActiveSheet.Range("A1").CurrentRegion

　'数値へ変換
　Range("B:B").Value = Range("B:B").Value
　Range("B:B").Replace What:=vbTab, Replacement:=""

　'集約したブックを保存して閉じる
　Application.DisplayAlerts = False
　B.SaveAs FileName:=PutBookName
　B.Close
　Application.DisplayAlerts = True

　MsgBox ("完了です")

End Sub

補足

早速、ご教示頂きまして、誠に有難うございました。
このコードで出力ファイルが作成出来ました。
すみません、もう2点ほど教えて頂きたい事があります。
1点目＝このマクロファイル、入力データ、出力ファイルをそれぞれ別のホルダーで指定したいです。
　例えば、
マクロファイル保存場所＝"C:\Users\Owner\Desktop\10_2023-参加者リスト\ｽｸﾘﾌﾟﾄ"
入力データ保存場所＝"C:\Users\Owner\Desktop\10_2023-参加者リスト\データ"
出力ファイル保存場所＝"C:\Users\Owner\Desktop\10_2023-参加者リスト\出力ファイル"
2点目＝出力ファイル名にマクロを実施した日付を追加したい。
例えば、出力ファイル名＝2023-参加者リスト纏_202307090145
色々と上記について試して見ましたが、エラーが出てしまい自力でコードを修正する事が出来ませんでした。
大変お手数ですが、よろしくお願いします。

回答No.2

HohoPapa

可能な限り、示されたコードを生かすコードとしてみました。

なお、なにやら、

　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If

このコードで
複写元のデータの行数が8行未満かどうかで動作が異なるようです。

また、

　ActiveSheet.CheckBoxes.Delete

これが何をやっているのかよくわからないです。
マクロブックのActiveSheetにCheckBoxesがあれば削除しているようです。
CheckBoxesが無ければ、単に空振りする動作です。

Option Explicit

Sub Macro2()

　Const PutBookName = "D:\TestDir\Sample.xlsx"

　Dim B As Workbook
　Dim O As Worksheet
　Dim FileName As String
　Dim ROut As Long
　Dim REnd As Long

　Set B = Workbooks.Add '出力先ブックを新規オープン
　Set O = B.Sheets(1)　　'出力先シートを定義

　'出力先、1行目の書き込みと列幅を設定
　With O
　　.Cells(1, "A") = "個人番号"
　　.Cells(1, "A").EntireColumn.ColumnWidth = 15
　　.Cells(1, "B") = "職員番号"
　　.Cells(1, "B").EntireColumn.ColumnWidth = 15
　　.Cells(1, "C") = "氏名"
　　.Cells(1, "C").EntireColumn.ColumnWidth = 15
　　.Cells(1, "D") = "所属/拠点"
　　.Cells(1, "D").EntireColumn.ColumnWidth = 15
　　.Cells(1, "E") = "所属/グループ"
　　.Cells(1, "E").EntireColumn.ColumnWidth = 15
　　.Cells(1, "F") = "役職"
　　.Cells(1, "F").EntireColumn.ColumnWidth = 15
　　.Cells(1, "G") = "開始年月日"
　　.Cells(1, "G").EntireColumn.ColumnWidth = 15
　　.Cells(1, "H") = "終了年月日"
　　.Cells(1, "H").EntireColumn.ColumnWidth = 15
　　.Cells(1, "I") = "申告"
　　.Cells(1, "I").EntireColumn.ColumnWidth = 15
　　.Cells(1, "J") = "判定1"
　　.Cells(1, "J").EntireColumn.ColumnWidth = 15
　　.Cells(1, "K") = "判定2"
　　.Cells(1, "K").EntireColumn.ColumnWidth = 15
　　.Cells(1, "L") = "判定3"
　　.Cells(1, "L").EntireColumn.ColumnWidth = 15
　　.Cells(1, "M") = "判定4"
　　.Cells(1, "M").EntireColumn.ColumnWidth = 15
　　.Cells(1, "N") = "判定5"
　　.Cells(1, "N").EntireColumn.ColumnWidth = 15
　End With

　FileName = Dir(ThisWorkbook.Path & "\参加者_*.xlsx")
　'Range("A2:N" & Rows.Count).ClearContents
　ActiveSheet.CheckBoxes.Delete

　ROut = 2
　Application.ScreenUpdating = False

　Do While FileName > ""
　　Workbooks.Open ThisWorkbook.Path & "\" & FileName, False, True
　　FileName = Replace(FileName, ".xlsx", "")

　　If ROut < 8 Then
　　　Rows("1:" & 8 - ROut).Delete
　　ElseIf ROut > 8 Then
　　　Rows("8:" & ROut - 1).Insert
　　End If

　　REnd = Cells(Rows.Count, "C").End(xlUp).Row
　　O.Range("A" & ROut, "A" & REnd) = Mid(FileName, 7)
　　Range("B" & ROut, "H" & REnd).Copy O.Range("B" & ROut)
　　Range("N" & ROut, "N" & REnd).Copy O.Range("I" & ROut)
　　Range("Q" & ROut, "U" & REnd).Copy O.Range("J" & ROut)

　　ROut = REnd + 1
　　ActiveWorkbook.Close False
　　FileName = Dir
　Loop

　 ' Range("A1").Select
　 ' Range("A1").CurrentRegion.ClearFormats
　 ' ActiveSheet.ListObjects.Add SourceType:=xlSrcRange, Source:=ActiveSheet.Range("A1").CurrentRegion

　'数値へ変換
　Range("B:B").Value = Range("B:B").Value
　Range("B:B").Replace What:=vbTab, Replacement:=""

　'集約したブックを保存して閉じる
　Application.DisplayAlerts = False
　B.SaveAs FileName:="D:\TestDir\Sample.xlsx"
　B.Close
　Application.DisplayAlerts = True

　MsgBox ("完了です")

End Sub

回答No.1

NuboChan

回答が付かないので
　とりあえずのVBAコードです。
（検証してませんので作動できるかは保証できません）

質問を下記のように理解しての回答です。

指定フォルダ内のExcelファイルを順に処理し、
各ファイルの各シートから列Aから列Nまでのデータを取得して、
新しいExcelファイルに出力しています。
（新しいExcelファイルは、指定したフォルダに保存）

Sub ExportData()

Dim MyFolder As String
Dim MyFile As String
Dim wbk As Workbook
Dim sht As Worksheet
Dim LastRow As Long
Dim i As Long
Dim j As Long
Dim OutputWorkbook As Workbook
Dim OutputWorksheet As Worksheet

'指定フォルダのパスを取得
MyFolder = "C:\Users\UserName\Documents\Excel Files\"

'新しいExcelファイルを作成
Set OutputWorkbook = Workbooks.Add

'新しいExcelファイルのシートを指定
Set OutputWorksheet = OutputWorkbook.Sheets(1)

'指定フォルダ内のExcelファイルを順に処理
MyFile = Dir(MyFolder & "*.xlsx")

Do While MyFile <> ""
'Excelファイルを開く
Set wbk = Workbooks.Open(MyFolder & MyFile)

'Excelファイルの各シートを順に処理
For Each sht In wbk.Sheets
'最終行を取得
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

'データを出力
For i = 1 To LastRow
For j = 1 To 14
OutputWorksheet.Cells(i, j).Value = sht.Cells(i, j).Value
Next j
Next i

'新しいExcelファイルに保存
OutputWorkbook.SaveAs "C:\Users\UserName\Documents\Output Files\" & sht.Name & ".xlsx"
Next sht

'Excelファイルを閉じる
wbk.Close SaveChanges:=False

'次のExcelファイルを取得
MyFile = Dir
Loop

'新しいExcelファイルを閉じる
OutputWorkbook.Close SaveChanges:=True

MsgBox ("Completed !!")

End Sub

お礼

この度は、誠に有難うございました。
ご教示頂きました、マクロは今後の参考にさせて頂きます。