【VBAマクロ初心者】Excel VBAで複数ファイルをマージする際にファイルがそれぞれヘッダーの項

【VBAマクロ初心者】Excel VBAで複数ファイルをマージする際にファイルがそれぞれヘッダーの項目が違い1つのファイルのヘッダーに合わせる為に不要な列を削除、足りない列には空白列を挿入したいのですが、後々ヘッダーの項目が変更になった際に削除する列や空白列を挿入する条件を変更できるようにしたいです。
また、マージ対象のフォルダやファイルの設定も可能にしてマージ後のファイル名も変更可能ですがデフォルトでは当日の日付(20191023.xls)にしたいですが、職場にマクロを組める人がいない状態です･･･【急いでいます】

質問者からの補足コメント

• ファイルのヘッダーは現在は49列項目があります。
  フォルダの中に5～7個のxls形式のファイルがあり、ファイル名は
  それぞれ
  台帳(*CT)B票データ.xls
  台帳(*QE)B票データ.xls
  台帳(*ST)B票データ.xls
  台帳(*IS)B票データ.xls
  台帳(*SST)B票データ.xls
  *には英数字が記載されています。
  
  今回はCTのヘッダーを基準に
  20191023.xls(ファイル名はマージ当日の日付をデフォルトに)のファイルを作成して同じフォルダに保存したいです。

    補足日時：2019/10/23 16:33

• 空白列の挿入や不要列の削除は以下のようにしていますが、この部分を可変で外部から設定できるようにしたいです。
  
  Sub test()
  Columns(11).Insert
  Columns(16).Insert
  Columns(18).Insert
  Columns(19).Insert
  Range("AY:CJ").Delete
  End Sub

    補足日時：2019/10/23 16:49

• 補足が多くてすみません
  フォルダの中にはマージしないフォルダも含まれているので
  イメージとしては
  ・マージ対象のフォルダ選択
  ・同フォルダ内にバックアップ用のフォルダをコピー
  ・マージ対象のフォルダを選択
  ・バックアップ用のフォルダ内にマージ用ファイルを保存
  ・バックアップ用のフォルダ内のファイルの不要列削除と足りない列は空白を挿入
  ・マージして最初のフォルダ内にマージした日付をファイル名として保存
  ・バックアップ用のフォルダを削除
  
  初心者の自分にはハードルが高くなかなか実装出来ません･･･
  どうか御教授お願いします。

    補足日時：2019/10/23 17:20

• ＞GooUserラックさん
  
  ①「バックアップ用のフォルダ」は作業用の仮のフォルダのことです。
  ②そのフォルダへのコピーもマクロで行いたいです。
  ③添付のような場合の結果は　基準にしたいヘッダーを上の「あ　いう　えお」にする場合は
  下の「か」の列は削除で「おあいえ」の列はそれぞれ上の「おあいえ」の列にマッピングしたいです。
  ちなみに1行目のヘッダー部分は全て埋まっている状態です。
  ④各ファイルはシートが1枚だけです。
  ⑤1つのファイルはデータのある列は全て同じ行まで埋まっています。
  ⑥ヘッダーは全てあるのですが中身が（2行目から下）空欄の列もあります。また基準にするCTのファイルよりもヘッダーが多いものもあります。その場合は多い分の列を削除したいです。またヘッダーの項目は一緒でもヘッダーの列がずれている場合があります。その場合は列を入れ替えるかマッピングして入力したいです。

  
    補足日時：2019/10/23 23:57

• ＞GooUserラックさん
  ①②マージ元となるファイルは「20191023」「20191024」とフォルダを毎日作って手作業でxls形式のファイルを手作業で入れています。このフォルダの中に保管フォルダとマクロ付ファイルを置きたいです。③ここは手動でも大丈夫です。
  ④⑤⑥依頼者（マクロは組めない）からは「基準にするヘッダーだけのマージ用のファイル（今回はCTのファイルをコピーしてのヘッダー以外の行を削除したもの）を作って、そこにマッピングする動きをファイル数分繰り返したら出来るんじゃないの？先に要らない列を削除してもいいしマージしてから削除してもいいし、ただし後々項目も変わるかもしれないから外部から可変出来る様にして欲しい」という　分かるような分からないような感じの動きで作ってほしいそうです。
  ⑦⑧　①②のファイルとマージ後のファイルだけを「20191023」に残して作業用は削除したいです。

  
    補足日時：2019/10/24 00:33

No.19 回答者： GooUserラック 回答日時： 2019/10/27 14:07

No.16 ～ No.18 の補足

実行時の画面を見ると気づくかもしれませんが、マージするときに２行目を使っています。また横に並べて処理したりもしていますので、１回で扱う基本のファイルとマージするファイルの列数の合計が256列を超えるとエラーします。
画面切り替えでチカチカしますが、場所によっては画面更新を止めてしまうと列数や行数を正しく認識出来ない可能性が有ります。（削除後に１度更新し、その後列数などを得れば良いのですが時間の関係で詰めていません）なのでとりあえずこのまま使っていて、時間をかけて画面更新を止める個所を増やしていくことをお勧めします。

この回答へのお礼

土日までありがとうございます。
早速自分のPCで動かして明日会社で確認してみます。なかなか思い通りに自分で作れず頼ってばかりですが、早くこのレベルを理解できるように勉強していきます。

お礼日時：2019/10/27 14:31

No.18 回答者： GooUserラック 回答日時： 2019/10/27 02:15

とりあえずこちらではエラーが出ず問題なく動いていそうです。

☆ 使用方法

① 空のフォルダを作り、そこにこのマクロ入りのファイルを保存して閉じます。
② そこに「基本ヘッダー.xls」と「削除ワード.txt」を作り保存して閉じます。
③ このマクロ入りファイルを開くと、必要な下位フォルダ自動で作成します。
④ メッセージが表示されたら「作業」ホルダーにマージしたいファイルをコピーして下さい。
⑤ 終了したら、メッセージを閉じて下さい（コピーが終わるまでは閉じないで下さい）
⑥ マージされたファイルは「保管」⇒「yyyy」⇒「mm」⇒「yyyymmdd.xls」で保存されます。
⑦「作業」ホルダーの中身は「mm_dd_BuckUp」に移動されます。

※ ①と②は初回だけ必要です
※「ファイル一覧」「作業」というシートは作らないで下さい。内部で勝手に作ったり削除したりします。
※「基本ヘッダー.xls」ですが、１行目しか使いませんので「台帳(*CT)B票データ.xls」をただリネームした物でも構いません。（２行目以降に説明を書き込んでも構いません）
※ ホルダーの構造を図のように「基準」⇒「保管」⇒「yyyy」⇒「mm」⇒「yyyymmdd.xls」に変更しました。
※「削除ワード.txt」は、文字コードを「ANSI」で保存して下さい。
※ モジュールをブロックに分けてみました。

この回答へのお礼

すみません
ThisWorkbook
の
Private Sub Workbook_Open()
Call フォルダ処理
End Sub
でコンパイルエラーが起きて
引数は省略できません。
と表示されていますがどういうことでしょうか？

お礼日時：2019/10/28 11:31

No.17 回答者： GooUserラック 回答日時： 2019/10/27 02:11

【文字制限の為分割①】

☆「ThisWorkbook」へ

Private Sub Workbook_Open()

　Call フォルダ処理

End Sub


☆「標準モジュール」へ

Sub 処理()

Dim Day_今日 As Date
Dim Lng_ファイル数 As Long
Dim Str_ファイル名 As String
Dim Obj_シート As Object

　Day_今日 = Date
　Application.DisplayAlerts = False
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "ファイル一覧" Then Obj_シート.Delete
　Next
　Application.DisplayAlerts = True
　Call フォルダ処理(Day_今日)
　If Dir(ThisWorkbook.Path & "\基本ヘッダー.xls") = "" Then
　　MsgBox ("「" & ThisWorkbook.Path & "」に「基本ヘッダー.xls」が有りません。作成してやり直してください")
　　Exit Sub
　End If
　MsgBox ("マージしたいファイルを作業フォルダにコピーして下さい。" & Chr(13) & _
　　　　　"（注意：コピーするとき移動にならないように注意してください。）" & Chr(13) & _
　　　　　"・このメッセージはコピーが終わるまで閉じないで下さい。")
　Lng_ファイル数 = ファイル数("台帳(*)B票データ.xls")
　If Lng_ファイル数 = 0 Then
　　MsgBox ("マージ用ファイルがコピーされていませんでした。" & Chr(13) & _
　　　　　　"・エクセルを一度閉じて、もう一度やり直して下さい。")
　Else
　　Call マージ処理(Lng_ファイル数)
　　Sheets("作業").Move
　　Str_ファイル名 = ThisWorkbook.Path & "\保管\" & _
　　　Format(Day_今日, "yyyy") & "\" & _
　　　Format(Day_今日, "mm") & "\" & _
　　　Format(Day_今日, "yyyymmdd") & ".xls"
　　If Dir(Str_ファイル名) <> "" Then Kill Str_ファイル名
　　ActiveWorkbook.SaveAs Filename:=Str_ファイル名
　　ActiveWindow.Close
　　Call ファイル移動(Day_今日)
　　MsgBox ("処理が終了しました")
　End If
　ThisWorkbook.Saved = True

End Sub

Sub フォルダ処理(Day_今日 As Date)
' 必要なフォルダは作成し、不要なフォルダは削除します。
Dim Day_日付 As Date
Dim Dic_削除フォルダ As Object
Dim Str_フルパス As String
Dim Str_パス As String
Dim Str_フォルダ名 As String
Dim Var_フォルダ名 As Variant
Dim Obj_フォルダ As Object
Set Obj_フォルダ = CreateObject("Scripting.FileSystemObject")
' 今あるフォルダを全部「削除フォルダ辞書」に登録
　Set Dic_削除フォルダ = CreateObject("Scripting.Dictionary")
　Str_フルパス = Dir(ThisWorkbook.Path & "\", vbDirectory)
　Do While Str_フルパス <> ""
　　If InStr(Str_フルパス, ".") = 0 Then Dic_削除フォルダ.Add Str_フルパス, 0
　　Str_フルパス = Dir()
　Loop
' 必要なフォルダが「辞書」に載っていたら辞書から抜き、載っていない場合は作成する
　If Dic_削除フォルダ.Exists("作業") Then
　　Dic_削除フォルダ.Remove ("作業")
　Else
　　MkDir (ThisWorkbook.Path & "\作業")
　End If
　If Dic_削除フォルダ.Exists("保管") Then
　　Dic_削除フォルダ.Remove ("保管")
　Else
　　MkDir (ThisWorkbook.Path & "\保管")
　End If
' バックアップ用のフォルダで必要な物は辞書から抜き、当日のフォルダが無ければ作成する。
　For Day_日付 = Day_今日 - 6 To Day_今日
　　Str_フォルダ名 = Format(Day_日付, "mm_dd") & "_BuckUp"
　　If Dic_削除フォルダ.Exists(Str_フォルダ名) Then
　　　Dic_削除フォルダ.Remove (Str_フォルダ名)
　　Else
　　　MkDir (ThisWorkbook.Path & "\" & Str_フォルダ名)
　　End If
　Next
'「辞書」に載っているフォルダを削除する
　Application.DisplayAlerts = False
　For Each Var_フォルダ名 In Dic_削除フォルダ
　　Obj_フォルダ.DeleteFolder ThisWorkbook.Path & "\" & Var_フォルダ名
　Next
　Application.DisplayAlerts = True
　Set Dic_削除フォルダ = Nothing
'「保管」フォルダー以下の、必要なフォルダを作成する。
　Str_パス = ThisWorkbook.Path & "\保管\" & Format(Day_今日, "yyyy")
　If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
　Str_パス = Str_パス & "\" & Format(Day_今日, "mm")
　If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)

End Sub

Sub マージ処理(Lng_ファイル数 As Long)

Dim Obj_シート As Object
Dim Lng_次横位置 As Long
Dim Lng_一覧位置 As Long

　Application.DisplayAlerts = False
'「作業」シート新規作成（既にある場合は作り直し）
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "作業" Then Obj_シート.Delete
　Next
　Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "作業"
　Cells.ColumnWidth = 2 ' ←ここは不要
'「基礎」シート新規作成（既にある場合は作り直し）
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "基礎" Then Obj_シート.Delete
　Next
　Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "基礎"
　Cells.ColumnWidth = 2 ' ←ここは不要
　Application.DisplayAlerts = True
'「基本ヘッダー.xls」のヘッダー部分のみ取込
　Workbooks.Open Filename:=ThisWorkbook.Path & "\基本ヘッダー.xls"
　Rows("1:1").Copy ThisWorkbook.Sheets("作業").Range("A1")
　Rows("1:1").Copy ThisWorkbook.Sheets("基礎").Range("A1")
　ActiveWindow.Close
' ２行目にインデックス番号を振る
　For Lng_次横位置 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　Cells(2, Lng_次横位置).Value = Lng_次横位置
　Next
' マージ処理
　For Lng_一覧位置 = Lng_ファイル数 + 1 To 2 Step -1
　　Call 下処理(Sheets("ファイル一覧").Cells(Lng_一覧位置, 1).Value, Lng_次横位置)
　Next
'　不要になった「基礎」シートを削除
　Application.DisplayAlerts = False
　Sheets("基礎").Delete
　Application.DisplayAlerts = True
'　特定ワード削除処理
　Call 特定ワード行削除("削除ワード.txt")

End Sub

No.16 回答者： GooUserラック 回答日時： 2019/10/27 02:09

【文字制限の為分割②】

Sub 下処理(Str_ファイル名, Lng_貼付位置 As Long)
　　
Dim Lng_横位置 As Long
Dim Lng_最終列 As Long
Dim Lng_最終行 As Long

　Workbooks.Open Filename:=ThisWorkbook.Path & "\作業\" & Str_ファイル名
　Rows(2).Insert Shift:=xlDown
　ActiveWorkbook.Saved = True
　With ActiveSheet.UsedRange
　　Lng_最終行 = .Rows(.Rows.Count).Row
　　Lng_最終列 = .Columns(.Columns.Count).Column
　End With
　Range(Cells(1, 1), Cells(Lng_最終行, Lng_最終列)).Copy ThisWorkbook.Sheets("基礎").Cells(1, Lng_貼付位置)
　ActiveWindow.Close
　Cells.Sort _
　　Key1:=Range("A1"), Order1:=xlAscending, _
　　Key2:=Range("A2"), Order2:=xlAscending, _
　　Header:=xlNo, _
　　Orientation:=xlLeftToRight
　For Lng_横位置 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(1, Lng_横位置).Value = Cells(1, Lng_横位置 + 1).Value Then
　　　If Cells(2, Lng_横位置).Value <> "" Then
　　　　Cells(2, Lng_横位置 + 1).Value = Cells(2, Lng_横位置).Value
　　　　Cells(2, Lng_横位置).Value = ""
　　　End If
　　End If
　Next
　For Lng_横位置 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　If Cells(2, Lng_横位置).Value = "" Then
　　　Columns(Lng_横位置).ClearContents
　　End If
　Next
　Cells.Sort _
　　Key1:=Range("A2"), Order1:=xlAscending, _
　　Header:=xlNo, _
　　Orientation:=xlLeftToRight
　Cells(3, 1).Select ' ←ここは不要
　Range(Cells(3, 1), Cells(Lng_最終行, Cells(1, Columns.Count).End(xlToLeft).Column)).Cut
　Sheets("作業").Select
　Rows("2:2").Insert Shift:=xlDown
　Sheets("基礎").Select

End Sub

Sub 特定ワード行削除(Str_ファイル名 As String)
' このブック同じフォルダに置かれている指定されてファイルに書かれた文字が有る行を削除します。
' ワイルドカード文字（｢?｣｢*｣）も使えます。
Dim Int_番号 As Integer
Dim Str_検索文字 As String
Dim Rng_セル As Range


　Int_番号 = FreeFile
　Open ThisWorkbook.Path & "\" & Str_ファイル名 For Input As #Int_番号
　Application.ScreenUpdating = False
　Do Until EOF(Int_番号)
　　Line Input #Int_番号, Str_検索文字
　　Set Rng_セル = Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)). _
　　　Find(Str_検索文字, , xlValues, xlWhole, xlByColumns, xlNext, True, True, False)
　　Do Until Rng_セル Is Nothing
　　　Rows(Rng_セル.Row).Delete Shift:=xlUp
　　　Set Rng_セル = Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).FindNext()
　　Loop
　Loop
　Application.ScreenUpdating = True
　Close #Int_番号

End Sub

Sub ファイル移動(Day_日付 As Date)
' 作業フォルダーのファイルを指定フォルダへ移動します。
Dim Str_移動元 As String
Dim Str_移動先 As String
Dim Obj_フォルダ As Object

　Set Obj_フォルダ = CreateObject("Scripting.FileSystemObject")
　Str_移動元 = ThisWorkbook.Path & "\作業\*.*"
　Str_移動先 = ThisWorkbook.Path & "\" & Format(Day_日付, "mm_dd") & "_BuckUp\"
　Obj_フォルダ.DeleteFile Str_移動先 & "*.*", True
　Obj_フォルダ.MoveFile Str_移動元, Str_移動先
　Set Obj_フォルダ = Nothing

End Sub

Function ファイル数(Str_共通名 As String) As Long
' 対象のファイル数を返し、一覧表を作成します。
' Str_共通名にはワイルドカード文字（｢?｣｢*｣）も使えます。
Dim Str_ファイル名 As String
Dim Lng_行番号 As Long

　Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ファイル一覧"
　Cells.ColumnWidth = 2 ' ←ここは不要
　Range("A1").Value = "マージファイル一覧"
　Str_ファイル名 = Dir(ThisWorkbook.Path & "\作業\" & "*.xls")
　Lng_行番号 = 2
　Do While Str_ファイル名 <> ""
　　If Str_ファイル名 Like Str_共通名 Then
　　　Cells(Lng_行番号, 1) = Str_ファイル名
　　　Lng_行番号 = Lng_行番号 + 1
　　End If
　　Str_ファイル名 = Dir()
　Loop
　ファイル数 = Cells(Rows.Count, 1).End(xlUp).Row - 1

End Function

No.15 回答者： めぐみん_ 回答日時： 2019/10/26 11:48

個人的にやるならADOでトライするでしょうね。

実際どの程度の変化（項目）があるのかによって判断式が変わるかもですが、BookのOPEN・CLOSEを繰り返すと被ってしまいつまらないでしょうから。
でも確実にコードの行数は増えると思いますね。
項目数を削る・入れ替えるはSQL文の基礎ですし、インサートについては調整次第でしょう。
と、直接の回答ではなく申し訳ないです。

今後を考えると実際メンテ出来る人が社内（？）にいないなら業者に出して仕様書と共に受け取った方が後々引き継ぐ際に良いとは思いますけどね。
昔OFFICE２０００が出た頃に大量の文書作成が必要となり、その為に派遣を雇入た事はあります。
社内で悩むより経験者を身近においてやる方がかなり早かったです。
急ぎならその辺の検討は厳しいでしょうけど、PC環境の違いにより悩むのならって事で。
後は在宅委託でしょうかね。

この回答へのお礼

ADOも早速調べてみました
方法が1つじゃないというところはやっぱりプログラムを組む楽しさですね
色んな方法が出てくるところは本当に尊敬します。皆さん凄いです。

お礼日時：2019/10/27 14:36

No.14 回答者： GooUserラック 回答日時： 2019/10/25 21:49

No.13 の補足

「マージしたいファイルを…」が表示中または事前に手動でマージファイルを作業フォルダにコピーされていれば実行できる筈です。
もしマクロが完全実行不能だとしたら根本的に無理ですが、途中まででも動くならダメな分だけ直せばよいのだとは思いますが「納期月曜まで」は難しいかもしれませんね

この回答へのお礼

いつも遅くまでありがとうございます。
先程退社して確認出来ておりませんでした･･･
マクロのコード以外にも色々と問題がありご迷惑をかけてすみません。
以前質問したCSVのマージは動いたのでマクロの実行は出来ると思うのですが、なかなかうまくいかないですね、月曜日の朝に動かせるか再度確認してみたいと思います。
また別の方法がないかもう少し調べてみたいと思います。

お礼日時：2019/10/25 22:00

No.13 回答者： GooUserラック 回答日時： 2019/10/25 21:40

マクロからエクスプローラが起動出来ないだけかもしれません。

以下は動きますか？

Sub 処理()

Dim Str_パス As String
Dim Obj_シート As Object
Dim Day_今日 As Date
Dim Lng_元番号 As Long
Dim Lng_列番号 As Long
Dim Str_ファイル名 As String
Dim Lng_対象数 As Long
Dim Str_作業パス As String
Dim Lng_行番号 As Long
Dim Lng_終番号 As Long
Dim Lng_次番号 As Long
Dim Lng_辞書位置 As Long
Dim Lng_最大行 As Long
Dim Dic_ヘッダー As Object
Set Dic_ヘッダー = CreateObject("Scripting.Dictionary")
Dim Var_ヘッダーキー As Variant
Dim Var_ヘッダー要素 As Variant
Dim Obj_フォルダ As Object
Set Obj_フォルダ = CreateObject("Scripting.FileSystemObject")
Dim Var_フォルダ As Variant

　Application.DisplayAlerts = False
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "作業" Then Obj_シート.Delete
　Next
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "ファイル一覧" Then Obj_シート.Delete
　Next
　Application.DisplayAlerts = True
　Day_今日 = Now
　Str_パス = ThisWorkbook.Path & "\" & "保管"
　If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
　Str_パス = Str_パス & "\" & Format(Day_今日, "yyyy")
　If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
　Str_パス = Str_パス & "\" & Format(Day_今日, "mm")
　If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
　Str_パス = ThisWorkbook.Path & "\" & "作業"
　If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
　MsgBox ("マージしたいファイルをドラッグ＆ドロップして下さい。" & Chr(13) & _
　　　　　"（注意：ドロップするときは必ず[Ctrl]キーを押しながら行ってください。）" & Chr(13) & _
　　　　　"・このメッセージはドラッグ＆ドロップが終わるまで閉じないで下さい。" & Chr(13) & _
　　　　　"・ドラッグ＆ドロップが終わったら必ずエクスプローラを閉じて下さい")
　If Dir(ThisWorkbook.Path & "\基本ヘッダー.xls") = "" Then
　　MsgBox ("「" & ThisWorkbook.Path & "」に「基本ヘッダー.xls」が有りません。作成してやり直してください")
　　Exit Sub
　End If
　Workbooks.Open Filename:=ThisWorkbook.Path & "\基本ヘッダー.xls"
　For Lng_列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　Dic_ヘッダー.Add Cells(1, Lng_列番号).Value, Lng_列番号
　Next
　Var_ヘッダーキー = Dic_ヘッダー.Keys()
　Var_ヘッダー要素 = Dic_ヘッダー.Items()
　Windows("基本ヘッダー.xls").Close
　Application.DisplayAlerts = False
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "作業" Then Obj_シート.Delete
　Next
　For Each Obj_シート In Sheets
　　If Obj_シート.Name = "ファイル一覧" Then Obj_シート.Delete
　Next
　Application.DisplayAlerts = True
　Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ファイル一覧"
　Range("A1").Value = "マージファイル一覧"
　Str_作業パス = ThisWorkbook.Path & "\作業\"
　Str_ファイル名 = Dir(Str_作業パス & "*.xls")
　Lng_行番号 = 1
　Do While Str_ファイル名 <> ""
　　Lng_行番号 = Lng_行番号 + 1
　　Cells(Lng_行番号, 1) = Str_ファイル名
　　Str_ファイル名 = Dir()
　Loop
　If Lng_行番号 = 1 Then
　　MsgBox ("マージファイルがコピーされていませんでした。" & Chr(13) & _
　　　　　　"・エクセルを一度閉じて、もう一度やり直して下さい。")
　　ThisWorkbook.Saved = True
　Else
　　Columns("A:A").Columns.AutoFit
　　Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "作業"
　　For Lng_辞書位置 = 0 To Dic_ヘッダー.Count - 1
　　　Cells(1, Var_ヘッダー要素(Lng_辞書位置)).Value = Var_ヘッダーキー(Lng_辞書位置)
　　Next
　　Lng_次番号 = 2
　　For Lng_行番号 = 2 To Sheets("ファイル一覧").Cells(Rows.Count, 1).End(xlUp).Row
　　　Str_ファイル名 = Sheets("ファイル一覧").Cells(Lng_行番号, 1).Value
　　　Workbooks.Open Filename:=Str_作業パス & Str_ファイル名
　　　ActiveSheet.Move After:=ThisWorkbook.Sheets(Worksheets.Count)
　　　Lng_最大行 = 0
　　　For Lng_列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　　　If Dic_ヘッダー.Item(Cells(1, Lng_列番号).Value) <> "" Then
　　　　　Lng_終番号 = Cells(Rows.Count, Lng_列番号).End(xlUp).Row
　　　　　If Lng_最大行 < Lng_終番号 Then Lng_最大行 = Lng_終番号
　　　　End If
　　　Next
　　　For Lng_列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
　　　　Lng_元番号 = Dic_ヘッダー.Item(Cells(1, Lng_列番号).Value)
　　　　If Lng_元番号 <> 0 Then
　　　　　Range(Cells(2, Lng_列番号), Cells(Lng_最大行, Lng_列番号)).Copy Sheets("作業").Cells(Lng_次番号, Lng_元番号)
　　　　End If
　　　Next
　　　Application.DisplayAlerts = False
　　　　ActiveWindow.SelectedSheets.Delete
　　　Application.DisplayAlerts = True
　　　Lng_次番号 = Lng_次番号 + Lng_最大行 - 1
　　Next
　　Sheets("作業").Move
　　Str_ファイル名 = ThisWorkbook.Path & "\保管\" & _
　　　Format(Day_今日, "yyyy") & "\" & _
　　　Format(Day_今日, "mm") & "\" & _
　　　Format(Day_今日, "yyyymmdd") & ".xls"
　　ActiveWorkbook.SaveAs Filename:=Str_ファイル名
　End If
　Set Dic_ヘッダー = Nothing
　Set Obj_フォルダ = Nothing

End Sub

No.12 回答者： GooUserラック 回答日時： 2019/10/25 16:22

No.10 の補足です。

多分 Excel2007 以降を使っていると思うのですが、このマクロ付ファイルは「Excel マクロ有効ブック(*.xlsm)」で保存するよりも「Excel 97-2003 ブック(*.xls)」で保存して互換モードで使用した方が良いようです。

「*.xlsm」の場合 Excel 2013 で使用すると途中で止まったようになり、やたら遅くなります。

No.11 回答者： GooUserラック 回答日時： 2019/10/25 15:32

No.10 の補足

文字数制限が有ったので字下げをカットしました。見にくくてすみません。
テストバージョンとして使ってエラーが出るなら、どこでエラーが出るかすぐご連絡下さい。

この回答へのお礼

職場からは教えてgooを開けないため
スマホからです
遅くなりました。
コピペも出来ずスマホから教えてgooを見てコードを手打ちしました。
ネットワークに繋がってない方の事務用PCでは正しく動作確認ができましたが

作らなければいけない開発用PCではアドミン権限が付与されておらず
エラーが起きてしまいました。
デバックとしては
Shell"C:￥Windows￥Explorer.exe" & Str_パス, vbNormalFocus
の部分が網掛けされています。
エラー内容は『 実行時エラー53:ファイルが見つかりません。』
と表示されていますがコードのStr_パスの上にマウスを乗せると
正しいパスが表示されました。
ヘルプを押してみると『 このファイルは所有者により別名保存(アップロード)が禁止されています。』とセキュリティプラットフォーム【EXCEL.EXE】のメッセージボックスが表示されました。

マクロ自体も 管理者として実行とかも出来ないみたいです。
処理としては作業フォルダや保管フォルダが作られましたが
マージのところでエラーなので
マージしたいファイルを～のメッセージボックスも表示されないみたいです･･･

色々教えてもらっているのに
何度も申し訳ないです。

お礼日時：2019/10/25 20:00

No.10 回答者： GooUserラック 回答日時： 2019/10/25 15:27

とりあえず「参照設定」をしないで No.7 の ②を実現した物です。

（多分エラーは出ないと思います）

☆「ThisWorkbook」へ

Private Sub Workbook_Open()
Call 処理
End Sub


☆「標準モジュール」へ

Sub 処理()
Dim Str_パス As String
Dim Obj_シート As Object
Dim Day_今日 As Date
Dim Lng_元番号 As Long
Dim Lng_列番号 As Long
Dim Str_ファイル名 As String
Dim Lng_対象数 As Long
Dim Str_作業パス As String
Dim Lng_行番号 As Long
Dim Lng_終番号 As Long
Dim Lng_次番号 As Long
Dim Lng_辞書位置 As Long
Dim Lng_最大行 As Long
Dim Dic_ヘッダー As Object
Set Dic_ヘッダー = CreateObject("Scripting.Dictionary")
Dim Var_ヘッダーキー As Variant
Dim Var_ヘッダー要素 As Variant
Dim Obj_フォルダ As Object
Set Obj_フォルダ = CreateObject("Scripting.FileSystemObject")
Dim Var_フォルダ As Variant
Application.DisplayAlerts = False
For Each Obj_シート In Sheets
If Obj_シート.Name = "作業" Then Obj_シート.Delete
Next
For Each Obj_シート In Sheets
If Obj_シート.Name = "ファイル一覧" Then Obj_シート.Delete
Next
Application.DisplayAlerts = True
Day_今日 = Now
Str_パス = ThisWorkbook.Path & "\" & "保管"
If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
Str_パス = Str_パス & "\" & Format(Day_今日, "yyyy")
If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
Str_パス = Str_パス & "\" & Format(Day_今日, "mm")
If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
Str_パス = ThisWorkbook.Path & "\" & "作業"
If Dir(Str_パス, vbDirectory) = "" Then MkDir (Str_パス)
Shell "C:\Windows\Explorer.exe " & Str_パス, vbNormalFocus
MsgBox ("マージしたいファイルをドラッグ＆ドロップして下さい。" & Chr(13) & _
"（注意：ドロップするときは必ず[Ctrl]キーを押しながら行ってください。）" & Chr(13) & _
"・このメッセージはドラッグ＆ドロップが終わるまで閉じないで下さい。" & Chr(13) & _
"・ドラッグ＆ドロップが終わったら必ずエクスプローラを閉じて下さい")
If Dir(ThisWorkbook.Path & "\基本ヘッダー.xls") = "" Then
MsgBox ("「" & ThisWorkbook.Path & "」に「基本ヘッダー.xls」が有りません。作成してやり直してください")
Exit Sub
End If
Workbooks.Open Filename:=ThisWorkbook.Path & "\基本ヘッダー.xls"
For Lng_列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
Dic_ヘッダー.Add Cells(1, Lng_列番号).Value, Lng_列番号
Next
Var_ヘッダーキー = Dic_ヘッダー.Keys()
Var_ヘッダー要素 = Dic_ヘッダー.Items()
Windows("基本ヘッダー.xls").Close
Application.DisplayAlerts = False
For Each Obj_シート In Sheets
If Obj_シート.Name = "作業" Then Obj_シート.Delete
Next
For Each Obj_シート In Sheets
If Obj_シート.Name = "ファイル一覧" Then Obj_シート.Delete
Next
Application.DisplayAlerts = True
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "ファイル一覧"
Range("A1").Value = "マージファイル一覧"
Str_作業パス = ThisWorkbook.Path & "\作業\"
Str_ファイル名 = Dir(Str_作業パス & "*.xls")
Lng_行番号 = 1
Do While Str_ファイル名 <> ""
Lng_行番号 = Lng_行番号 + 1
Cells(Lng_行番号, 1) = Str_ファイル名
Str_ファイル名 = Dir()
Loop
If Lng_行番号 = 1 Then
MsgBox ("マージファイルがコピーされていませんでした。" & Chr(13) & _
"・エクセルを一度閉じて、もう一度やり直して下さい。")
ThisWorkbook.Saved = True
Else
Columns("A:A").Columns.AutoFit
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = "作業"
For Lng_辞書位置 = 0 To Dic_ヘッダー.Count - 1
Cells(1, Var_ヘッダー要素(Lng_辞書位置)).Value = Var_ヘッダーキー(Lng_辞書位置)
Next
Lng_次番号 = 2
For Lng_行番号 = 2 To Sheets("ファイル一覧").Cells(Rows.Count, 1).End(xlUp).Row
Str_ファイル名 = Sheets("ファイル一覧").Cells(Lng_行番号, 1).Value
Workbooks.Open Filename:=Str_作業パス & Str_ファイル名
ActiveSheet.Move After:=ThisWorkbook.Sheets(Worksheets.Count)
Lng_最大行 = 0
For Lng_列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
If Dic_ヘッダー.Item(Cells(1, Lng_列番号).Value) <> "" Then
Lng_終番号 = Cells(Rows.Count, Lng_列番号).End(xlUp).Row
If Lng_最大行 < Lng_終番号 Then Lng_最大行 = Lng_終番号
End If
Next
For Lng_列番号 = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
Lng_元番号 = Dic_ヘッダー.Item(Cells(1, Lng_列番号).Value)
If Lng_元番号 <> 0 Then
Range(Cells(2, Lng_列番号), Cells(Lng_最大行, Lng_列番号)).Copy Sheets("作業").Cells(Lng_次番号, Lng_元番号)
End If
Next
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
Lng_次番号 = Lng_次番号 + Lng_最大行 - 1
Next
Sheets("作業").Move
Str_ファイル名 = ThisWorkbook.Path & "\保管\" & _
Format(Day_今日, "yyyy") & "\" & _
Format(Day_今日, "mm") & "\" & _
Format(Day_今日, "yyyymmdd") & ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=Str_ファイル名
ActiveWindow.Close
Obj_フォルダ.DeleteFolder ThisWorkbook.Path & "\作業"
Application.DisplayAlerts = True
End If
Set Dic_ヘッダー = Nothing
Set Obj_フォルダ = Nothing
End Sub