今回は、その1で作成した
『同じフォルダ内にあるCSVファイルを使用範囲をそのままコピペして統合するマクロ』
を貼り付け用の「請求統合.xlsx」を前もって用意し、コピー範囲の開始行をinputboxで指定できるよう改良しました。
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ファイル名の一部を入力する」の対応をしたいと思います。