あなたは複数のCSVデータなどをExcelのフォーマットに転記していくのが面倒だと思ったことはありませんか？
単なるコピペではなく、テンプレートの書式を維持したいときがありますよね。
例えば、10人分のメンバーのCSVデータを、Excelのフォーマットに値の貼付けでコピペして、ファイル名を付けて保存するのを10回やるのは面倒です。
Aさんのファイルを開いて、集計ファイルにコピペして、
Bさんのファイルを開いて、集計ファイルにコピペして、
Cさんのファイルを開いて、集計ファイルにコピペして・・・１０人分やったら大変。
そんなときはExcel VBAを使えば、コピペも保存も簡単です。
今回は「Excelで複数ファイルの値の転記・別名保存を連続処理する方法」を紹介します。
Excelで複数ファイルの値の転記・別名保存を連続処理する方法
Excelで複数ファイルの値の転記・別名保存を連続処理する方法です。
今回は、集計フォーマットのファイルに、Ａ，Ｂ，Ｃのデータを貼り付けるのを例に紹介します。
集計フォーマットはこうなっています。
Ａ，Ｂ，Ｃのファイルは値だけが入っています。
Aのファイル
Bのファイル
Cのファイル
マクロを作るときは、「開発」タブを使います。
開発タブが出ていない方は、下のリンクで出し方を紹介していますので、まずは準備をお願いします。
→エクセルで開発タブを表示する方法
１．「開発」タブをクリック →「挿入」をクリック →「ボタン」をクリック
２．「新規作成」をクリック
３．コード入力画面が開く
４．コードを入力
コードを入力します。
Aファイルを開いて、フォーマットに値の貼付け、ファイル名を付けて保存する。B、Cも繰り返す、という内容です。
５．ボタンができた
ボタンができた
６．ボタンを押す →処理完了
ボタンを押すと、「すべての処理が完了しました」と出ました。
Ａ，Ｂ，Ｃのファイルを確認します。
Aファイル
セルの色、罫線、書式などが反映されています。
Bファイル
こちらも問題なし。
Cファイル
これも大丈夫です。
これでフォーマットへデータを転記するのがになりましたね！
まとめ
Excelで複数ファイルの値の転記・別名保存を連続処理する方法です。
１．「開発」タブをクリック →「挿入」をクリック →「ボタン」をクリック
２．新規作成をクリック
３．コード入力画面が開く
４．コードを入力
５．ボタンができた
６．ボタンを押す →処理完了
これでCSVデータを、テンプレートの書式を維持したまま、コピペできる ＆ 複数ファイルの作成から元ファイルの整理まで一括自動化できるので、かなり時短になりました！
最後に今回使ったコードです。
Dim wbTemplate As Workbook
Dim wbSource As Workbook
Dim wbCopy As Workbook
Dim wsTemplate As Worksheet
Dim wsSource As Worksheet
Dim wsCopy As Worksheet
Dim folderPath As String
Dim searchText As String
Dim sourcePath As String
Dim tempXlsm As String
Dim tempXlsx As String
Dim finalPath As String
Dim backupPath As String
Dim fileName As String
Dim baseName As String
Dim ext As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim data As Variant
Dim found As Boolean
Dim successCount As Long
Dim shp As Shape
Dim ole As OLEObject
On Error GoTo ErrorHandler
Set wbTemplate = ThisWorkbook
Set wsTemplate = wbTemplate.Worksheets(1)
If wbTemplate.Path = "" Then
MsgBox "先に元のExcelファイルを保存してください。", vbExclamation
Exit Sub
End If
folderPath = wbTemplate.Path & "\"
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
'I2～I4を順番に処理
For i = 2 To 4
searchText = Trim(CStr(wsTemplate.Cells(i, "I").Value))
If searchText = "" Then
MsgBox "I" & i & "セルが空白です。処理を終了します。", vbExclamation
GoTo ExitHandler
End If
found = False
sourcePath = ""
'----------------------------------
'1. 該当するExcelファイルを検索
'----------------------------------
fileName = Dir(folderPath & "*.*")
Do While fileName <> ""
ext = LCase(Mid(fileName, InStrRev(fileName, ".") + 1))
If ext = "xlsx" Or ext = "xlsm" _
Or ext = "xls" Or ext = "xlsb" Then
If InStr(1, fileName, searchText, vbTextCompare) > 0 Then
If StrComp(fileName, wbTemplate.Name, vbTextCompare) <> 0 _
And InStr(1, fileName, "-1.", vbTextCompare) = 0 _
And InStr(1, fileName, "_削除待ち", vbTextCompare) = 0 Then
sourcePath = folderPath & fileName
found = True
Exit Do
End If
End If
End If
fileName = Dir()
Loop
If found = False Then
MsgBox "該当するファイルが見つかりません。" & vbCrLf & _
"検索文字列：" & searchText, vbExclamation
GoTo ExitHandler
End If
'ファイル名を取得
baseName = Left(sourcePath, InStrRev(sourcePath, ".") - 1)
ext = Mid(sourcePath, InStrRev(sourcePath, "."))
'一時保存ファイル名
tempXlsx = baseName & "-1.xlsx"
'最終保存ファイル名
finalPath = baseName & ".xlsx"
'元ファイルの退避先
backupPath = baseName & "_削除待ち" & ext
'保存先の重複確認
If Dir(tempXlsx) <> "" Then
MsgBox "一時保存ファイルが既に存在します。" & vbCrLf & _
tempXlsx, vbExclamation
GoTo ExitHandler
End If
If Dir(backupPath) <> "" Then
MsgBox "退避用ファイルが既に存在します。" & vbCrLf & _
backupPath, vbExclamation
GoTo ExitHandler
End If
'----------------------------------
'2. 元のExcelファイルをコピー
'----------------------------------
tempXlsm = Environ("TEMP") & "\Template_" & _
Format(Now, "yyyymmddhhnnss") & "_" & i & ".xlsm"
wbTemplate.SaveCopyAs tempXlsm
Set wbCopy = Workbooks.Open(tempXlsm)
'----------------------------------
'3. 取込元ファイルを開く
'----------------------------------
Set wbSource = Workbooks.Open(sourcePath, ReadOnly:=True)
Set wsSource = wbSource.Worksheets(1)
'A1:G17の値を取得
data = wsSource.Range("A1:G17").Value
'元のフォーマットに値だけ貼り付け
Set wsCopy = wbCopy.Worksheets(wsTemplate.Index)
wsCopy.Range("A1:G17").Value = data
'取込元ファイルを閉じる
wbSource.Close SaveChanges:=False
Set wbSource = Nothing
'----------------------------------
'4. VBAボタンを削除
'----------------------------------
For j = 1 To wbCopy.Worksheets.Count
Set wsCopy = wbCopy.Worksheets(j)
'フォームコントロールのボタンと
'マクロが登録された図形を削除
For k = wsCopy.Shapes.Count To 1 Step -1
Set shp = wsCopy.Shapes(k)
If shp.Type = 8 Then
If shp.FormControlType = 0 Then
shp.Delete
End If
ElseIf shp.OnAction <> "" Then
shp.Delete
End If
Next k
'ActiveXのコマンドボタンを削除
For k = wsCopy.OLEObjects.Count To 1 Step -1
Set ole = wsCopy.OLEObjects(k)
If InStr(1, ole.progID, _
"CommandButton", vbTextCompare) > 0 Then
ole.Delete
End If
Next k
Next j
'----------------------------------
'5. I2～I4の文字列を削除
'----------------------------------
For j = 1 To wbCopy.Worksheets.Count
wbCopy.Worksheets(j).Range("I2:I4").ClearContents
Next j
'----------------------------------
'6. xlsx形式で一時保存
'----------------------------------
wbCopy.SaveAs fileName:=tempXlsx, _
FileFormat:=xlOpenXMLWorkbook
wbCopy.Close SaveChanges:=False
Set wbCopy = Nothing
'----------------------------------
'7. 元ファイルを退避
'----------------------------------
Name sourcePath As backupPath
'----------------------------------
'8. -1を取り除いて正式保存
'----------------------------------
On Error GoTo RenameError
Name tempXlsx As finalPath
On Error GoTo ErrorHandler
'----------------------------------
'9. 元ファイルを削除
'----------------------------------
Kill backupPath
'一時テンプレートを削除
Kill tempXlsm
tempXlsm = ""
successCount = successCount + 1
Next i
MsgBox "すべての処理が完了しました。" & vbCrLf & _
"処理件数：" & successCount & "件", vbInformation
ExitHandler:
On Error Resume Next
If Not wbSource Is Nothing Then
wbSource.Close SaveChanges:=False
End If
If Not wbCopy Is Nothing Then
wbCopy.Close SaveChanges:=False
End If
If tempXlsm <> "" Then
If Dir(tempXlsm) <> "" Then Kill tempXlsm
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
Exit Sub
'----------------------------------
'ファイル名変更エラー
'----------------------------------
RenameError:
On Error Resume Next
'元ファイルを復元
If Dir(backupPath) <> "" Then
Name backupPath As sourcePath
End If
On Error GoTo ErrorHandler
MsgBox "ファイル名の変更に失敗しました。" & vbCrLf & _
"一時保存ファイルは残っています。" & vbCrLf & _
tempXlsx, vbCritical
GoTo ExitHandler
'----------------------------------
'その他のエラー
'----------------------------------
ErrorHandler:
MsgBox "エラーが発生しました。" & vbCrLf & _
"エラー番号：" & Err.Number & vbCrLf & _
"内容：" & Err.Description, vbCritical
Resume ExitHandler