0
3

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?

More than 5 years have passed since last update.

フォルダ内のCSVファイルを統合するマクロ その2

Posted at

今回は、その1で作成した
『同じフォルダ内にあるCSVファイルを使用範囲をそのままコピペして統合するマクロ』
を貼り付け用の「請求統合.xlsx」を前もって用意し、コピー範囲の開始行をinputboxで指定できるよう改良しました。
image.png

Sub tougou02()
   
'フォルダを選択
    Dim folderPath As Variant
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        folderPath = .SelectedItems(1)
    End With
       
'Dir関数でCSVファイル名を取得
    Dim buf As String
    buf = Dir(folderPath & "\" & "*.csv")
    Debug.Print buf        'ファイル名を確認
    
'貼り付け元の「請求統合.xlsx」ファイルを開いて最初のシートを指定
    Dim bath As Workbook
    Set bath = Workbooks.Open(folderPath & "\" & "請求統合.xlsx")
    Dim tougouWs As Worksheet
    Set tougouWs = bath.Worksheets(1)
    
'CSVファイルの転記位置が上から何行目かをインプットボックスで指定
'(「j」が空白を入力されたときにメッセージを出したいので、Long型ではなくString型を指定)
    Dim j As String
    j = InputBox("CSVファイルの転記の開始は何行目ですか?(半角英数で入力してください)")
    
    If j = "" Then
        MsgBox "空白が入力されました。最初からやり直してください"
        Exit Sub
    End If
     
'CSVファイルの一番右下のセルの位置
    Dim maxRows As Long
    maxRows = Cells(1, Columns.Count).End(xlToLeft).Column
       
'ループ開始・CSVファイルの名前が空白になったら(取得できなかったら)ループから外れる
    Do While buf <> ""
    
'「請求統合.xlsx」の最終行を取得
        With tougouWs
            Dim bathLastLine As Long
            bathLastLine = .Cells(Rows.Count, 1).End(xlUp).Row
        End With
    
'CSVファイルの最初のシートを取得
            Dim wb As Workbook
            Set wb = Workbooks.Open(folderPath & "\" & buf)
            Dim ws As Worksheet
            Set ws = wb.Worksheets(1)
       
'CSVファイルの最下行を取得し範囲指定してコピー(クリップボード)
'最終行:lastLine
            Dim csvLastLine As Long
            csvLastLine = ws.Cells(Rows.Count, 1).End(xlUp).Row
            ws.Range(Cells(j, 1), Cells(csvLastLine, maxRows)).Copy
        
'「請求統合.xlsx」のA列の最終行の次のセルを指定し貼り付け
            With tougouWs
                .Activate
                .Cells(bathLastLine + 1, 1).Activate
            End With
            ActiveSheet.Paste

'CSVファイルを保存せずに閉じる
            wb.Application.CutCopyMode = False
            wb.Saved = True
            wb.Close
                      
'次のCSVファイルを指定する
            buf = Dir()
    Loop
    
'「請求統合.xlsx」を保存して閉じる
    bath.Save
    bath.Close
    
End Sub

ちなみに下記の部分ですが

'CSVファイルの転記位置が上から何行目かをインプットボックスで指定
'(「j」が空白を入力されたときにメッセージを出したいので、Long型ではなくString型を指定)
    Dim j As String
    j = InputBox("CSVファイルの転記の開始は何行目ですか?(半角英数で入力してください)")

    If j = "" Then
        MsgBox "空白が入力されました。最初からやり直してください"
        Exit Sub
    End If

inputboxをLongで宣言すると、何も入力しないまま「OK」をクリックするとエラーになってしまうので文字列であるStringで宣言したのですが・・・いいのでしょうかね?一応検証した結果はStringでもコピペはできました。

次回は個人的に追加したい機能「統合時に一番右のセルに各CSVファイル名の一部を入力する」の対応をしたいと思います。

0
3
0

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
0
3

Delete article

Deleted articles cannot be recovered.

Draft of this article would be also deleted.

Are you sure you want to delete this article?