Edited at

複数のEXCELファイルに一括コピペする

More than 1 year has passed since last update.

複数のEXCELにコピーしていく作業が面倒だったのでスクリプト作りました。


使い方

image.png

スクリプトファイルと同じ階層に「コピー元」「コピー先」フォルダを用意します。

スクリプトファイルを編集します。編集するのは以下の変数です。

- baseFolder (スクリプトのファイルパス)

- copyBaseFile (コピー元フォルダに配置されたファイルパス)

- copyBaseSheetName (コピー元ファイルのシート名)

- copyBaseRange (コピー元ファイルのコピー対象セル範囲)

- pasteSheetName(コピー先ファイルのシート名)

- pasteRange (コピー先ファイルのペースト対象セル範囲)


ExcelCopyPaste.vbs

baseFolder = "C:XXXXXXXX\ExcelCopyPaste"

copyBaseFolder = baseFolder & "\" & "コピー元"
copyDistFolder = baseFolder & "\" & "コピー先"

copyBaseFile = copyBaseFolder & "\" & "XXXXX.xlsx"
copyBaseSheetName = "XXXXX"
copyBaseRange = "A1:A1"

pasteSheetName = "YYYYY"
pasteRange = "A1:A1"



実行

コピー元ファイルで指定したシートの対象セル範囲を、コピー先フォルダに配置されたファイル全てに対してペーストします。


ソース


ExcelCopyPaste.vbs

Option Explicit

' ======================================================================================
' 変数定義
'
' ======================================================================================

Dim objFSO ' FileSystemObject
Dim baseFolder ' 作業フォルダパス
Dim copyBaseFolder ' コピー元フォルダパス
Dim copyDistFolder ' コピー先フォルダパス
Dim copyBaseFile ' コピー先ファイル名
Dim copyBaseSheetName ' コピー元シート名
Dim copyBaseRange ' コピー元セル範囲

Dim pasteSheetName ' コピー先シート名
Dim pasteRange

' ======================================================================================
' パラメータ設定(環境に合わせて定義すること)
'
' ======================================================================================

baseFolder = "C:XXXXXXXX\ExcelCopyPaste"

copyBaseFolder = baseFolder & "\" & "コピー元"
copyDistFolder = baseFolder & "\" & "コピー先"

copyBaseFile = copyBaseFolder & "\" & "XXXXX.xlsx"
copyBaseSheetName = "XXXXX"
copyBaseRange = "A1:A1"

pasteSheetName = "YYYYY"
pasteRange = "A1:A1"

'エラー情報をクリアする。
Err.Clear

' ======================================================================================
' EXCELコピー&ペースト
'
' ======================================================================================
Set objFSO = WScript.CreateObject("Scripting.FileSystemObject")
If Err.Number = 0 Then
' コピー元からセル範囲を選択し、クリップボードに貼り付ける
Dim excelObj, copyBaseFileObj, copyBaseSheetObj, distFolderObj
Set excelObj = WScript.CreateObject("Excel.Application")

If objFSO.FileExists(copyBaseFile) Then
Set copyBaseFileObj = excelObj.Workbooks.Open(copyBaseFile)
Set copyBaseSheetObj = copyBaseFileObj.Worksheets(copyBaseSheetName)

copyBaseSheetObj.Range(copyBaseRange).Copy

Set distFolderObj = objFSO.GetFolder(copyDistFolder)

' コピー先ファイル群の指定箇所に貼り付ける

' FolderオブジェクトのFilesプロパティからFileオブジェクトを取得
Dim objFile
For Each objFile In distFolderObj.Files
'EXCELファイルか判定
Dim ext
ext = objFSO.GetExtensionName(objFile.Name)

If ext = "xlsx" Or ext = "xlsm" Then
' WScript.Echo objFile.Name & "にペーストします。"

Dim excelObj2, pasteFilePath, pasteFileObj, pasteSheetObj

Set excelObj2 = WScript.CreateObject("Excel.Application")

pasteFilePath = copyDistFolder & "\" & objFile.Name

Set pasteFileObj = excelObj2.Workbooks.Open(pasteFilePath)

Set pasteSheetObj = pasteFileObj.Worksheets(pasteSheetName)

pasteSheetObj.Activate
pasteSheetObj.Range(pasteRange).Select
' 値のみコピー -4104
pasteSheetObj.Range(pasteRange).PasteSpecial(-4104)

pasteFileObj.Save
pasteFileObj.Close
Set pasteFileObj = Nothing

excelObj2.Quit
Set excelObj2 = Nothing
Set pasteSheetObj = Nothing

' WScript.Echo objFile.Name & "にペースト完了しました。"

End If

Next

'コピーするセル数が100以上のときに表示されるダイアログを非表示にする
copyBaseFileObj.Application.CutCopyMode = False
copyBaseFileObj.Close
Set copyBaseFileObj = Nothing

excelObj.Quit
Set excelObj = Nothing
Set copyBaseSheetObj = Nothing
Set distFolderObj = Nothing

WScript.Echo "EXCELシートのコピー&ペーストが完了しました。"

Else
WScript.Echo "コピー元のファイルが存在しないため処理を終了します。"
WScript.Quit
End If

Set objFSO = Nothing

End If