VBScript：Excel集約ツール

by chasou_tech · 公開済み 2022年5月24日 · 更新済み 2023年2月10日

同じフォーマットのExcelファイルを一つに集約するツールを作ってほしい！
という依頼が来たので作ってみました。

◆依頼内容・PC環境

あるシステムからダウンロードされるExcelファイルを一つにまとめたい

手作業でやっているので時間がかかし、間違うしでどうにかしたい

ファイル数は都度変動し、数十個あるときもある

シートの数は5個で変わらない

各ファイルのフォーマットは同じで、上の3行は項目名として結合などして使っている。

PC環境はWindows10でOffice2016を使用している

◆目標とツール概要

やることはいたってシンプルなので、ユーザのPC環境と依頼内容を踏まえて、VBScripで以下のようなツールを作ることにしました。

VBScriptに集約したいファイルをドラッグ＆ドロップすることで実行するようにする。

保存先を自由に指定できるようにする。

形式の異なったファイルを間違ってドロップした場合を考慮する。

シートの上3行が項目で、結合などもされている点も考慮する。

◆ツール全容

結果として、以下のツールが完成しました。
レコード数やPCのスペックもよりますが20個ぐらいのファイルで実行したところ、1分かからず終了しました。

Option Explicit
'================================'
'グローバル変数を宣言する'
	Dim SFPath
	Dim tFileCount
	Dim objFSO
	Dim FPathFrom
	Dim FPathTo
	Dim FNameArray()
	Dim FPathArray()
	Dim SheetCount()
	Dim SheetNameArray()

'================================'
'処理開始'
     main()
'処理終了'
'================================'
Sub main()
	'ファイルシステムオブジェクト'
	Set objFSO = CreateObject("Scripting.FileSystemObject")

	'//ドラッグ&ドロップしたファイルの情報取得'
	getFileDir()
	IF tFileCount <1 THEN
		MsgBox "結合するファイルをツールにドロップしてください。処理を中断します。"
		Exit Sub
	ElseIf tFileCount =1 THEN
		MsgBox "ファイルが一つしかありません。処理を中断します。"
		Exit Sub
	ElseIF tFileCount > 1 THEN
		If MsgBox("集約を実行します。", vbYesNo) = vbYes Then
		Else
			MsgBox "終了します。"
			Exit Sub
		End If
	End IF

	'//保存先の取得'
	SaveFolder()

	'//集約用テンプレートの作成'
	tempExcelFile()

	'//シート名の取得'
	getSheetName()

	On Error Resume Next
 	'//Excel情報の集約'
	aggExcelData()

	IF Err.Number <> 0 Then
		DelFile()
		MsgBox "集約するファイルに誤りがあります。ドロップしたファイルを確認してください。"
		Set objFSO = Nothing
		Exit Sub 
	End If 
	On Error Goto 0

	'オブジェクト変数をクリア'
	Set objFSO = Nothing
	MsgBox "集約処理が完了しました。"

End Sub

'================================'
'ドラッグ&ドロップしたファイルの情報取得'
'================================'
Sub getFileDir()
	'ドラッグアンドドロップで取得したファイルパスを変数に入れる'
	Dim GetPathArray
	Set GetPathArray = WScript.Arguments

	tFileCount = GetPathArray.Count

	Dim FPath 
	Dim i

	Redim FNameArray(tFileCount-1) 
	Redim FPathArray(tFileCount-1)

	'ファイルの数だけループする' 
	i = 0 
	For Each FPath in GetPathArray
		' 取得したファイル名'
		Dim FileName 

		FileName = objFSO.GetFileName (FPath)

		FNameArray(i) = FileName 
		FPathArray(i) = FPath

		i=i+1
	Next

End Sub

'================================'
'保存先の取得'
'================================'
Sub SaveFolder()
	'変数の宣言'
	Const msoFileDialogFolderPicker = 4
	Dim scriptPath
	Dim objExcel

	scriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "") 
	Set objExcel = CreateObject("Excel.Application")
	objExcel.Visible = False

	With objExcel.FileDialog (msoFileDialogFolderPicker)
		.Title = "フォルダを選択してください" 
		.InitialFileName = scriptPath
		If .Show Then
			SFPath = .Selecteditems(1)
		Else
			Exit Sub 
		End If

	End With

	objExcel.Visible = True 
	Set objExcel = Nothing

END Sub

'================================'
'Excelテンプレートのコピー'
'================================'
Sub tempExcelFile()
	'変数の宣言'
	Dim SDate

	SDate = Replace(FormatDateTime(Now(),2),"/","") 

	FPathFrom = FPathArray(0) 
	FPathTo = SFPath & "\集約_" & SDate & ".xlsx"

	Call objFSO.CopyFile(FPathFrom, FPathTo) 

End Sub

'================================'
'Excelテンプレートのシート名取得'
'================================'
Sub getSheetName()
	Redim SheetNameArray(5)
	SheetNameArray (0) = "Sheet1" 
	SheetNameArray (1) = "Sheet2" 
	SheetNameArray (2) = "Sheet3" 
	SheetNameArray (3) = "Sheet4"
	SheetNameArray (4) = "Sheet5"
End Sub

'================================'
'Excel情報の集約'
'================================'
Sub aggExcelData()
	'変数の宣言'
	Dim objExcel
	Dim wbTemp
	Dim wbMoto
	Dim shtTemp 
	Dim shtMoto
	Dim TemplatePath
	Dim CopyFPath
	Dim TemplateRow
	Dim TemplateCol
	Dim CopyRow
	Dim CopyLastRow
	Dim FSheetName
	Dim i
	Dim k

	Const xlUp = -4162

	Set objExcel = CreateObject("Excel.Application")
	objExcel.Visible = False

	TemplatePath = FPathTo
	Set wbTemp = objExcel.Workbooks.Open(TemplatePath)

	For i = 1 To Ubound (FPathArray)
		CopyFPath = FPathArray (i) 

		Set wbMoto = objExcel.Workbooks.Open(CopyFPath)

		For k = 0 To Ubound (SheetNameArray)
			FSheetName = SheetNameArray(k)
			Set shtTemp = wbTemp. Worksheets(FSheetName)
			Set shtMoto = wbMoto. Worksheets(FSheetName)

			'貼り付け先の最終行の取得'
			TemplateRow = shtTemp.Range("A1048576").End (xlUp).Row + 1
			IF TemplateRow <= 3 Then
				TemplateRow = 4
			End IF

			'コピー元のの最終行の取得'
			CopyRow = shtMoto.Range("A1048576").End (xlUp).Row

			If CopyRow > 3 Then
				'フォーマットにコピー貼り付け'
				shtMoto.Range("A4:BV"& CopyRow). Copy	shtTemp.Range("A" & TemplateRow)
			End If
			
			Set shtTemp = Nothing
			Set shtMoto = Nothing

		Next

		wbMoto.Close
		Set wbMoto = Nothing
	Next

	objExcel.Visible = True
	wbTemp.Save 
	wbTemp.Close

	Set objExcel = Nothing
	Set wbTemp = Nothing
End Sub

'================================'
'ファイル削除'
'================================'
Sub DelFile()
	objFSO.DeleteFile FPathTo
End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

136

137

138

139

140

141

142

143

144

145

146

147

148

149

150

151

152

153

154

155

156

157

158

159

160

161

162

163

164

165

166

167

168

169

170

171

172

173

174

175

176

177

178

179

180

181

182

183

184

185

186

187

188

189

190

191

192

193

194

195

196

197

198

199

200

201

202

203

204

205

206

207

208

209

210

211

212

213

214

215

216

217

218

219

220

221

222

223

224

225

226

227

228

229

Option Explicit

'================================'

'グローバル変数を宣言する'

Dim SFPath

Dim tFileCount

Dim objFSO

Dim FPathFrom

Dim FPathTo

Dim FNameArray()

Dim FPathArray()

Dim SheetCount()

Dim SheetNameArray()

'================================'

'処理開始'

main()

'処理終了'

'================================'

Sub main()

'ファイルシステムオブジェクト'

Set objFSO = CreateObject("Scripting.FileSystemObject")

'//ドラッグ&ドロップしたファイルの情報取得'

getFileDir()

IF tFileCount <1 THEN

MsgBox "結合するファイルをツールにドロップしてください。処理を中断します。"

Exit Sub

ElseIf tFileCount =1 THEN

MsgBox "ファイルが一つしかありません。処理を中断します。"

Exit Sub

ElseIF tFileCount > 1 THEN

If MsgBox("集約を実行します。", vbYesNo) = vbYes Then

Else

MsgBox "終了します。"

Exit Sub

End If

End IF

'//保存先の取得'

SaveFolder()

'//集約用テンプレートの作成'

tempExcelFile()

'//シート名の取得'

getSheetName()

On Error Resume Next

'//Excel情報の集約'

aggExcelData()

IF Err.Number <> 0 Then

DelFile()

MsgBox "集約するファイルに誤りがあります。ドロップしたファイルを確認してください。"

Set objFSO = Nothing

Exit Sub

End If

On Error Goto 0

'オブジェクト変数をクリア'

Set objFSO = Nothing

MsgBox "集約処理が完了しました。"

End Sub

'================================'

'ドラッグ&ドロップしたファイルの情報取得'

'================================'

Sub getFileDir()

'ドラッグアンドドロップで取得したファイルパスを変数に入れる'

Dim GetPathArray

Set GetPathArray = WScript.Arguments

tFileCount = GetPathArray.Count

Dim FPath

Dim i

Redim FNameArray(tFileCount-1)

Redim FPathArray(tFileCount-1)

'ファイルの数だけループする'

i = 0

For Each FPath in GetPathArray

' 取得したファイル名'

Dim FileName

FileName = objFSO.GetFileName (FPath)

FNameArray(i) = FileName

FPathArray(i) = FPath

i=i+1

End Sub

'================================'

'保存先の取得'

'================================'

Sub SaveFolder()

'変数の宣言'

Const msoFileDialogFolderPicker = 4

Dim scriptPath

Dim objExcel

scriptPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")

Set objExcel = CreateObject("Excel.Application")

objExcel.Visible = False

With objExcel.FileDialog (msoFileDialogFolderPicker)

.Title = "フォルダを選択してください"

.InitialFileName = scriptPath

If .Show Then

SFPath = .Selecteditems(1)

Else

Exit Sub

End If

End With

objExcel.Visible = True

Set objExcel = Nothing

END Sub

'================================'

'Excelテンプレートのコピー'

'================================'

Sub tempExcelFile()

'変数の宣言'

Dim SDate

SDate = Replace(FormatDateTime(Now(),2),"/","")

FPathFrom = FPathArray(0)

FPathTo = SFPath & "\集約_" & SDate & ".xlsx"

Call objFSO.CopyFile(FPathFrom, FPathTo)

End Sub

'================================'

'Excelテンプレートのシート名取得'

'================================'

Sub getSheetName()

Redim SheetNameArray(5)

SheetNameArray (0) = "Sheet1"

SheetNameArray (1) = "Sheet2"

SheetNameArray (2) = "Sheet3"

SheetNameArray (3) = "Sheet4"

SheetNameArray (4) = "Sheet5"

End Sub

'================================'

'Excel情報の集約'

'================================'

Sub aggExcelData()

'変数の宣言'

Dim objExcel

Dim wbTemp

Dim wbMoto

Dim shtTemp

Dim shtMoto

Dim TemplatePath

Dim CopyFPath

Dim TemplateRow

Dim TemplateCol

Dim CopyRow

Dim CopyLastRow

Dim FSheetName

Dim i

Dim k

Const xlUp = -4162

Set objExcel = CreateObject("Excel.Application")

objExcel.Visible = False

TemplatePath = FPathTo

Set wbTemp = objExcel.Workbooks.Open(TemplatePath)

For i = 1 To Ubound (FPathArray)

CopyFPath = FPathArray (i)

Set wbMoto = objExcel.Workbooks.Open(CopyFPath)

For k = 0 To Ubound (SheetNameArray)

FSheetName = SheetNameArray(k)

Set shtTemp = wbTemp. Worksheets(FSheetName)

Set shtMoto = wbMoto. Worksheets(FSheetName)

'貼り付け先の最終行の取得'

TemplateRow = shtTemp.Range("A1048576").End (xlUp).Row + 1

IF TemplateRow <= 3 Then

TemplateRow = 4

End IF

'コピー元のの最終行の取得'

CopyRow = shtMoto.Range("A1048576").End (xlUp).Row

If CopyRow > 3 Then

'フォーマットにコピー貼り付け'

shtMoto.Range("A4:BV"& CopyRow). Copy shtTemp.Range("A" & TemplateRow)

End If

Set shtTemp = Nothing

Set shtMoto = Nothing

wbMoto.Close

Set wbMoto = Nothing

objExcel.Visible = True

wbTemp.Save

wbTemp.Close

Set objExcel = Nothing

Set wbTemp = Nothing

End Sub

'================================'

'ファイル削除'

'================================'

Sub DelFile()

objFSO.DeleteFile FPathTo

End Sub

VBScript：Excel集約ツール

◆依頼内容・PC環境

◆目標とツール概要

◆ツール全容

●関連記事

VBScript基礎11：FileSystemObject

VBScript基礎4：配列

VBScript基礎9：ファイルのコピーや削除（FileSystemObject利用）

VBScript基礎8：WScriptオブジェクト。ドラッグ＆ドロップでファイル名やパスを取得する

VBScript基礎3：変数のスコープ

カテゴリー

プロフィール

Facebook

チャイ専門店　茶窓

Blog＆SNS

写真の販売

【PR】サーバー・PC購入はこちらから

ブログについて

最近の投稿

VBScript：Excel集約ツール

◆依頼内容・PC環境

◆目標とツール概要

◆ツール全容

●関連記事

VBScript基礎11：FileSystemObject

VBScript基礎4：配列

VBScript基礎9：ファイルのコピーや削除（FileSystemObject利用）

VBScript基礎8：WScriptオブジェクト。ドラッグ＆ドロップでファイル名やパスを取得する

VBScript基礎3：変数のスコープ

カテゴリー

プロフィール

Facebook

チャイ専門店 茶窓

Blog＆SNS

写真の販売

【PR】サーバー・PC購入はこちらから

ブログについて

最近の投稿

チャイ専門店　茶窓