读入文件并写入另一文件的vba例子

Const SHEET_CONFIG = "config"
Const RNG_CFG_TEMPLATE = "B3"
Const RNG_CFG_CSV_GROUP = "B7"
Const RNG_CFG_CSV_TRHKSK = "B5"
Const RNG_CFG_OUTPUT = "B9"

Const SHEET_DATA_GROUP = "業態別グループ別伝票枚数実績"
Const SHEET_DATA_TRHKSK = "取引先別業態別出荷実績"
Const FILE_NAME = "実績データ抽出"
Const TEMPLATE = "テンプレート"
Const CSV_FILE_TRHKSK = "CSVファイル(取引先別)"
Const CSV_FILE_GROUP = "CSVファイル(グループ別)"
Const OUTPUT_DIR = "出力フォルダ"

Sub ChooseTemplate_Click()
Dim target As Range

Set target = Worksheets(SHEET_CONFIG).Range(RNG_CFG_TEMPLATE)
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "グループ別テンプレートファイル選択"
'.InitialFileName = Left(target.Value, InStrRev(target.Value, "\"))
.InitialFileName = Application.ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "Excelテンプレート", "*.xls"

If .Show = True Then
target.Value = .SelectedItems(1)
End If
End With
End Sub

Sub ChooseCsvTrhksk_Click()
Dim target As Range

Set target = Worksheets(SHEET_CONFIG).Range(RNG_CFG_CSV_TRHKSK)
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "取引先別CSVファイル選択"
'.InitialFileName = Left(target.Value, InStrRev(target.Value, "\"))
.InitialFileName = Application.ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "CSVファイル", "*.csv"

If .Show = True Then
target.Value = .SelectedItems(1)
End If
End With
End Sub

Sub ChooseCsvGroup_Click()
Dim target As Range

Set target = Worksheets(SHEET_CONFIG).Range(RNG_CFG_CSV_GROUP)
With Application.FileDialog(msoFileDialogFilePicker)
.Title = "グループ別CSVファイル選択"
'.InitialFileName = Left(target.Value, InStrRev(target.Value, "\"))
.InitialFileName = Application.ActiveWorkbook.Path
.AllowMultiSelect = False
.Filters.Clear
.Filters.Add "CSVファイル", "*.csv"

If .Show = True Then
target.Value = .SelectedItems(1)
End If
End With
End Sub

Sub ChooseOutFolder_Click()
Dim target As Range

Set target = Worksheets(SHEET_CONFIG).Range(RNG_CFG_OUTPUT)
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "ファイル出力フォルダ選択"
'.InitialFileName = target.Value
.InitialFileName = Application.ActiveWorkbook.Path
.AllowMultiSelect = False

If .Show = True Then
target.Value = .SelectedItems(1)
End If
End With
End Sub

Sub OutputWeeklyReport_Click()
Dim toolBook As Workbook
Dim configSheet As Worksheet
Dim csvFilePath1 As String
Dim csvFilePath2 As String
Dim outputDir As String
Dim templateFile As String
Dim outBook As Workbook
Dim outFilePath As String
Dim time As String
Dim buf As String
Dim tmp As Variant
Dim tmp2 As Variant
Dim i As Long
Dim topValue As String
Dim wb As Object
Dim lastCol As Integer

' On Error GoTo ERROR

'画面の再描画を停止する
Application.ScreenUpdating = False

Set toolBook = Application.ActiveWorkbook
Set configSheet = toolBook.Worksheets(SHEET_CONFIG)
csvFilePath1 = configSheet.Range(RNG_CFG_CSV_GROUP).Value
csvFilePath2 = configSheet.Range(RNG_CFG_CSV_TRHKSK).Value
outputDir = configSheet.Range(RNG_CFG_OUTPUT).Value
templateFile = configSheet.Range(RNG_CFG_TEMPLATE).Value

If templateFile = "" Then
MsgBox TEMPLATE & "を指定してください。", 0 + 16
GoTo ERROR
End If
If csvFilePath1 = "" Then
MsgBox CSV_FILE_GROUP & "を指定してください。", 0 + 16
GoTo ERROR
End If
If csvFilePath2 = "" Then
MsgBox CSV_FILE_TRHKSK & "を指定してください。", 0 + 16
GoTo ERROR
End If
If outputDir = "" Then
MsgBox OUTPUT_DIR & "を指定してください。", 0 + 16
GoTo ERROR
End If

If Dir(templateFile) = "" Then
MsgBox TEMPLATE & "が見つかりません。", 0 + 16
GoTo ERROR
End If
If Dir(csvFilePath1) = "" Then
MsgBox CSV_FILE_GROUP & "が見つかりません。", 0 + 16
GoTo ERROR
End If
If Dir(csvFilePath2) = "" Then
MsgBox CSV_FILE_TRHKSK & "が見つかりません。", 0 + 16
GoTo ERROR
End If
If Dir(outputDir, vbDirectory) = "" Then
MsgBox OUTPUT_DIR & "が見つかりません。", 0 + 16
GoTo ERROR
End If

If Left(Right(csvFilePath1, 23), 19) <> Left(Right(csvFilePath2, 23), 19) Then
MsgBox "「" & CSV_FILE_GROUP & "」と" & "「" & CSV_FILE_TRHKSK & "」の" & "対象期間不一致。", 0 + 16
GoTo ERROR
Else
time = Left(Right(csvFilePath1, 23), 19)
Application.DisplayAlerts = True
End If

For Each wb In Workbooks
If wb.Name = FILE_NAME & time & ".xls" Then
MsgBox "「" & wb.Name & "」が開いています。", 0 + 16
GoTo ERROR
End If
Next

Set outBook = Workbooks.Add(templateFile)


Open csvFilePath1 For Input As #1
Line Input #1, buf
Close #1
tmp = Replace(buf, """", "")
tmp = Split(buf, vbLf)

For i = 1 To UBound(tmp) - 1
tmp2 = Split(tmp(i), ",")
With outBook.Worksheets(SHEET_DATA_GROUP)
If i <> UBound(tmp) - 1 Then
.Rows(i + 1).Copy
.Rows(i + 2).PasteSpecial Paste:=xlAll
End If

.Cells(i + 1, 1).Value = tmp2(0)
.Cells(i + 1, 2).Value = tmp2(1)
.Cells(i + 1, 3).Value = tmp2(2)
.Cells(i + 1, 4).Value = tmp2(3)
.Cells(i + 1, 5).Value = tmp2(4)
.Cells(i + 1, 6).Value = tmp2(5)
.Cells(i + 1, 7).Value = tmp2(6)
.Cells(i + 1, 8).Value = tmp2(7)
.Cells(i + 1, 9).Value = tmp2(8)
End With
Next i

Open csvFilePath2 For Input As #1
Line Input #1, buf
Close #1
tmp = Replace(buf, """", "")
tmp = Split(buf, vbLf)

For i = 1 To UBound(tmp) - 1
tmp2 = Split(tmp(i), ",")

With outBook.Worksheets(SHEET_DATA_TRHKSK)

.Rows(i + 2).Copy
.Rows(i + 3).PasteSpecial Paste:=xlAll

.Cells(i + 2, 1).Value = tmp2(0)
topValue = .Cells(i + 1, 1).Value
If tmp2(0) = topValue Then
.Cells(i + 2, 1).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
.Cells(i + 2, 2).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
End If
.Cells(i + 2, 2).Value = tmp2(1)
.Cells(i + 2, 3).Value = tmp2(2)
topValue = .Cells(i + 1, 3).Value
If tmp2(2) = topValue Then
.Cells(i + 2, 3).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
End If
.Cells(i + 2, 4).Value = tmp2(3)
topValue = .Cells(i + 1, 4).Value
If tmp2(3) = topValue Then
.Cells(i + 2, 4).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
.Cells(i + 2, 5).Borders(xlEdgeTop).LineStyle = xlLineStyleNone
End If
.Cells(i + 2, 5).Value = tmp2(4)
.Cells(i + 2, 6).Value = tmp2(5)
.Cells(i + 2, 7).Value = tmp2(6)
.Cells(i + 2, 8).Value = tmp2(7)
.Cells(i + 2, 9).Value = tmp2(8)
.Cells(i + 2, 10).Value = tmp2(9)
.Cells(i + 2, 11).Value = tmp2(10)
.Cells(i + 2, 12).Value = tmp2(11)
.Cells(i + 2, 13).Value = tmp2(12)
.Cells(i + 2, 14).Value = tmp2(13)
.Cells(i + 2, 15).Value = tmp2(14)
End With
Next i
lastCol = UBound(tmp) + 2
With outBook.Worksheets(SHEET_DATA_TRHKSK)
.Cells(lastCol, 1).Value = "総計"
.Cells(lastCol, 8).Value = WorksheetFunction.Sum(.Range(.Cells(3, 8), .Cells(lastCol, 8)))
.Cells(lastCol, 9).Value = WorksheetFunction.Sum(.Range(.Cells(3, 9), .Cells(lastCol, 9)))
.Cells(lastCol, 10).Value = WorksheetFunction.Sum(.Range(.Cells(3, 10), .Cells(lastCol, 10)))
.Cells(lastCol, 11).Value = WorksheetFunction.Sum(.Range(.Cells(3, 11), .Cells(lastCol, 11)))
.Cells(lastCol, 12).Value = WorksheetFunction.Sum(.Range(.Cells(3, 12), .Cells(lastCol, 12)))
.Cells(lastCol, 13).Value = WorksheetFunction.Sum(.Range(.Cells(3, 13), .Cells(lastCol, 13)))
.Cells(lastCol, 14).Value = WorksheetFunction.Sum(.Range(.Cells(3, 14), .Cells(lastCol, 14)))
.Cells(lastCol, 15).Value = WorksheetFunction.Sum(.Range(.Cells(3, 15), .Cells(lastCol, 15)))
End With
outBook.Worksheets(SHEET_DATA_TRHKSK).Activate
Range("A1").Activate
outBook.Worksheets(SHEET_DATA_GROUP).Activate
Range("A1").Activate

Application.DisplayAlerts = False
outFilePath = outputDir & "\" & FILE_NAME & time & ".xls"
outBook.SaveAs Filename:=outFilePath, FileFormat:=xlWorkbookNormal
outBook.Close

Application.DisplayAlerts = True

'画面の再描画を再開する
Application.ScreenUpdating = True

MsgBox "ファイルの作成が完了しました。"

Exit Sub

ERROR:
Application.DisplayAlerts = False
Close #1
Application.DisplayAlerts = True
End Sub