EXCEL超初心者マクロ（SAMPLE16）ファイル合体。
久しぶりにUPです。
EXCELやCSVが沢山あって、一つずつ合体させることってないですか？
デイリーのデータを毎週、毎月なんて面倒ですよね。
場合によっては100個ぐらいあったりしたら間違いのもとになります。
数個なら大した手間でもないし、CSVならコマンドプロンプトの「TYPE」コマンドでできたりするのですが、EXCELは手動で切り貼りが必要です。
実は、社内で要望があり、作ったので、それを参考にサンプルを作成しました
SAMPLE16.zip
※Cドライブ直下に解凍してください。KANRIシートで基本ホルダは変更できます。
※ダウンロードする際は、必ずウイルスチェックをしてくださいね。またサンプルは自由にご使用になって結構ですが、当方で責任は一切負えませんのでご了承ください。
流れ
・フォルダ情報を取得して一覧作成FILEKANRI
KANRIにパス情報
FILEKANRIにファイル情報
・上記で取得した情報から、ファイルをEXCELで開いて、INPUTへコピー後、OUTPUTへ追加。
分けているのは、データによってヘダーが有ったり、編集したりいろいろあるため、分けています。
・一気に取り込みまで作ることも出来るのですが、あえて処理ミスを防ぐため、取り込むファイル名を目視できるようにしています。
【注意】
CSVで12桁以上の数値が入っていたり、前ゼロがあると想定通りにならないかもしれません。
取り込むEXCELが大きかったり、複雑な構成（セルの結合）をしてる場合は張り付けるときにメモリ不足のエラーになることがあります。
データだけ取り込みたかったら以下の部分を直せば大丈夫かもしれません。
Paste:=xlPasteValues '### 文字列のみ
File情報取得
MSG_FLG = MsgBox(" FILEKANRI へ 取込みファイルの情報を取得します。 " & vbCrLf & " 実行ＯＫ? ", vbYesNo)
If MSG_FLG = vbNo Then
Exit Sub
End If
' Application.ScreenUpdating = False
mySheetName001 = "FILEKANRI"
' ***クリア処理***
'### シートフィルタ解除サブプロシジー ###
sheet_clear
'### シートクリア ###
Sheets(mySheetName001).Select
Worksheets(mySheetName001).Cells.Clear
Range("A1").Select
Const cnsTITLE = "○ファイル取込み処理"
Const cnsFILTER = " (*.*),*.*"
'
'### 基本ディレクトリ
With CreateObject("WScript.Shell")
.CurrentDirectory = Worksheets("KANRI").Range("B1")
End With
'### フォルダ名取得ダイアログでフォルダ名取得
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
FOLDERPATH = .SelectedItems(1)
End With
Worksheets("KANRI").Range("B5") = FOLDERPATH
'### 取得場所準備
Set set_data01 = Worksheets(mySheetName001).Range("A1")
CNT01 = 0
set_data01.Offset(CNT01, 0).value = "取込みファイル名"
'### 取得したパス内のファイル名を取得。
WORK01 = Dir(FOLDERPATH & "\*.*")
Do While WORK01 <> ""
CNT01 = CNT01 + 1
set_data01.Offset(CNT01, 0).value = WORK01
WORK01 = Dir()
Loop
Application.StatusBar = "ファイル情報取得"
MsgBox (" ファイル情報取得(^^) ")
File取込&追加
MSG_FLG = MsgBox(" FILEKANRI のデータを 取込み追加します。 " & vbCrLf & " 実行ＯＫ? ", vbYesNo)
If MSG_FLG = vbNo Then
Exit Sub
End If
Application.ScreenUpdating = False
mySheetName001 = "FILEKANRI"
mySheetName002 = "INPUT"
mySheetName003 = "OUTPUT"
' ***クリア処理***
'### シートフィルタ解除サブプロシジー ###
sheet_clear
Set set_data01 = Worksheets(mySheetName001).Range("A2")
Set set_data03 = Worksheets(mySheetName003).Range("A1")
Do Until set_data01.Offset(0, 0).value = ""
'#############################################
'### コピーANDペースト
'#############################################
'### シートクリア ###
Sheets(mySheetName002).Select
Worksheets(mySheetName002).Cells.Clear
Range("A1").Select
'### 元Sheet セット
Set writeSheet = ThisWorkbook.Worksheets(mySheetName002)
'### シート名セット ###
vFILENAME = Worksheets("KANRI").Range("B5") & "\" & set_data01.Offset(0, 0).value
Set strBookName = Workbooks.Open(vFILENAME) '相手オープン
Cells.Select
Selection.Copy
writeSheet.Activate '元選択（download）
Cells.Select
ActiveSheet.Select
Range("A1").PasteSpecial '### 全て貼り付け
'Range("A1").PasteSpecial Paste:=xlPasteValues '### 文字列のみ
'### 相手クローズ クリップモードメッセージ、保存メッセージ、飛ばす
Application.CutCopyMode = False
Application.DisplayAlerts = False
strBookName.Close savechanges:=False
Application.DisplayAlerts = True
writeSheet.Activate '元選択（download）
Set writeSheet = Nothing
Set strBookName = Nothing
ActiveSheet.Cells.ClearOutline
'#############################################
'### 追加
'#############################################
Set set_data02 = Worksheets(mySheetName002).Range("A1")
Do Until set_data02.Offset(0, 0).value = ""
set_data03.Offset(0, 0).value = set_data02.Offset(0, 0).value
set_data03.Offset(0, 1).value = set_data02.Offset(0, 1).value
set_data03.Offset(0, 2).value = set_data02.Offset(0, 2).value
set_data03.Offset(0, 3).value = set_data02.Offset(0, 3).value
' set_data03.Offset(0, 4).value = set_data02.Offset(0, 4).value
' set_data03.Offset(0, 5).value = set_data02.Offset(0, 5).value
' set_data03.Offset(0, 6).value = set_data02.Offset(0, 6).value
' set_data03.Offset(0, 7).value = set_data02.Offset(0, 7).value
' set_data03.Offset(0, 8).value = set_data02.Offset(0, 8).value
' set_data03.Offset(0, 9).value = set_data02.Offset(0, 9).value
'########## 次行 #############
Set set_data02 = set_data02.Offset(1, 0)
Set set_data03 = set_data03.Offset(1, 0)
Loop
'########## 次行 #############
Set set_data01 = set_data01.Offset(1, 0)
Loop
Application.ScreenUpdating = True
Sheets(mySheetName003).Select
Range("A1").Select
Application.StatusBar = "取込みEND"
MsgBox (" 処理END(^^) ")