EXCEL超初心者マクロ（SAMPLE16）ファイル合体。

2019年5月24日

久しぶりに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(^^) ")