Option Explicit
Option Base 1
'==================================================
' モジュール名: Mod_ImportFile
' 概要: CSVファイルのインポート機能を提供するモジュール
' 主な機能: ファイル取込、項目リスト処理、シート出力
'==================================================
'--------------------------------------------------
' 構造体：CSV項目とそのデータ
'--------------------------------------------------
Type typCsvItem
strItemName As String
arrStrValues() As String
End Type
'--------------------------------------------------
'プロシージャの概要:
'処理名:onClickImportFile
'概要:CSVファイル取込ボタン押下時のメイン処理。
'項目定義とCSVファイル内容を読み込み、shImportシートに出力する。
'--------------------------------------------------
Sub onClickImportFile()
On Error GoTo lblErr
Dim arrTypItems() As typCsvItem
Dim strCsvFolder As String
Dim strCsvFile As String
Dim strFilePath As String
Dim strMsg As String
' フォルダパス・ファイル名を取得
Call getCsvPath(strCsvFolder, strCsvFile)
' フォルダ存在確認
If Not blnExistsFolder(strCsvFolder) Then Exit Sub
'ファイル名チェック
'実装中
' フルパス生成
strFilePath = strCsvFolder & strCsvFile
' ファイル存在確認
If Not blnExistsFile(strFilePath) Then Exit Sub
' 項目リストの読込
If blnTypGetItemList(arrTypItems) = False Then Exit Sub
' CSVデータの読込
If blnLoadCsvData(strFilePath, arrTypItems) = False Then Exit Sub
' shImportへの出力
If blnWriteImportSheet(arrTypItems) = False Then Exit Sub
' 処理完了通知
strMsg = "ファイルの取込が完了しました。"
MsgBox strMsg, vbInformation, "onClickImportFile : 完了"
Exit Sub
lblErr:
MsgBox "ファイル取込処理中にエラーが発生しました。" & vbCrLf & _
"エラー番号: " & Err.Number & vbCrLf & _
"内容: " & Err.Description, vbExclamation, "onClickImportFile"
End Sub
'--------------------------------------------------
'プロシージャの概要:
'処理名:blnLoadCsvData
'概要:指定されたCSVファイルを開き、構造体配列に対応する項目のデータを一括取得して格納する
'[引数1]:strPath:読み込むCSVファイルのフルパス
'[引数2]:arrItems:読み込んだデータを格納する構造体配列（項目名に一致する列の値）
'[戻り値]:Boolean:正常終了時 True、エラー発生時 False
'--------------------------------------------------
Private Function blnLoadCsvData(ByVal strPath As String, ByRef arrItems() As typCsvItem) As Boolean
Dim wbCsv As Workbook ' 読み込むCSVファイルのワークブック
Dim wsCsv As Worksheet ' CSVファイル内のワークシート（1枚目）
Dim lngCol As Long ' 列ループ用
Dim lngRow As Long ' 行ループ用
Dim lngLastCol As Long ' CSV内の最終列番号
Dim lngItemIndex As Long ' 構造体配列ループ用
Dim strItemName As String ' 構造体内の項目名
Dim strHeader As String ' CSVのヘッダー項目名（10行目）
Dim strErrMsg As String ' エラーメッセージ格納用文字列
Dim varColumnData As Variant ' 列データ一括取得用配列
' エラーハンドリング開始
On Error GoTo lblErr
' CSVファイルを読み取り専用で開く
Set wbCsv = Workbooks.Open(Filename:=strPath, ReadOnly:=True)
Set wsCsv = wbCsv.Worksheets(1)
With wsCsv
' 最終列番号の取得（10行目の最右列）
lngLastCol = .Cells(ROW_CSV_HEADER, .Columns.Count).End(xlToLeft).Column
' 構造体配列の各項目についてデータを読み込む
For lngItemIndex = LBound(arrItems) To UBound(arrItems)
' 対象項目名を取得
strItemName = arrItems(lngItemIndex).strItemName
For lngCol = 1 To lngLastCol
' CSVヘッダーから項目名を取得
strHeader = .Cells(ROW_CSV_HEADER, lngCol).Value
' 一致しない列はスキップ
If strHeader <> strItemName Then GoTo SkipColumn
' 対応列のデータを一括取得
varColumnData = .Range(.Cells(ROW_CSV_START, lngCol), _
.Cells(ROW_CSV_START + NUM_CSV_ROWS - 1, lngCol)).Value
' 値格納用の配列を初期化
ReDim arrItems(lngItemIndex).arrStrValues(1 To NUM_CSV_ROWS)
' 取得した列データを構造体に格納
For lngRow = 1 To NUM_CSV_ROWS
arrItems(lngItemIndex).arrStrValues(lngRow) = varColumnData(lngRow, 1)
Next lngRow
' 対応列が見つかったので次の項目へ
Exit For
SkipColumn:
Next lngCol
Next lngItemIndex
End With
' CSVファイルを保存せずに閉じる
wbCsv.Close SaveChanges:=False
blnLoadCsvData = True
Exit Function
lblErr:
' エラー発生時の処理
If Err.Number <> 0 Then
strErrMsg = "CSV読込処理中にエラーが発生しました。" & vbCrLf & _
"内容: " & Err.Description
Else
strErrMsg = "予期せぬ理由によりCSV読込処理が中断されました。"
End If
MsgBox strErrMsg, vbExclamation, "blnLoadCsvData"
If Not wbCsv Is Nothing Then wbCsv.Close SaveChanges:=False
blnLoadCsvData = False
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:blnTypGetItemList
'概要:shItemsシートの項目名一覧を構造体配列に格納して返却（エラー時はFalse）
'[引数1]:arrTypItems:読み込んだ項目名を格納する構造体配列
'[戻り値]:Boolean: 正常終了時はTrue、エラー時はFalse
'--------------------------------------------------
Private Function blnTypGetItemList(ByRef arrTypItems() As typCsvItem) As Boolean
Dim lngLastRow As Long ' 項目列の最終行番号
Dim lngItemCount As Long ' 項目数
Dim lngIndex As Long ' ループカウンタ
Dim lngRow As Long ' セルの行番号
Dim strItemName As String ' セルから読み取った項目名
Dim strErrMsg As String ' エラーメッセージ格納用文字列
On Error GoTo lblErr
' 項目列（B列）最終行を取得
lngLastRow = shItems.Cells(shItems.Rows.Count, COL_shITM_NAME).End(xlUp).Row
' 項目数を算出
lngItemCount = lngLastRow - ROW_shITM_START + 1
' 項目が存在しない場合はエラーとして処理終了
If lngItemCount <= 0 Then
strErrMsg = "項目リストが空であるため処理を続行できません。"
GoTo lblErr
End If
' 構造体配列を初期化
ReDim arrTypItems(1 To lngItemCount)
' 項目名を構造体に格納
For lngIndex = 1 To lngItemCount
lngRow = ROW_shITM_START + lngIndex - 1 ' 対象セルの行番号を算出
strItemName = shItems.Cells(lngRow, COL_shITM_NAME).Value ' セルから項目名を取得
arrTypItems(lngIndex).strItemName = strItemName ' 構造体に格納
Next lngIndex
blnTypGetItemList = True
Exit Function
lblErr:
If Err.Number <> 0 Then
strErrMsg = "項目リストの読込中にエラーが発生しました。" & vbCrLf & _
"内容: " & Err.Description
End If
MsgBox strErrMsg, vbExclamation, "blnTypGetItemList"
blnTypGetItemList = False
End Function
'--------------------------------------------------
'プロシージャの概要:
'処理名:blnWriteImportSheet
'概要:構造体配列に格納された項目名およびCSVデータをshImportシートに出力する。
' 各行の右端にはSUM関数による合計列も追加する。
'[引数1]:arrTypItems:出力対象となる項目名と値を持つ構造体配列
'[戻り値]:Boolean:正常終了時 True、エラー発生時 False
'--------------------------------------------------
Function blnWriteImportSheet(ByRef arrTypItems() As typCsvItem) As Boolean
Dim lngRow As Long ' 行ループ用カウンタ
Dim lngCol As Long ' 列インデックス
Dim lngItemIndex As Long ' 構造体配列インデックス
Dim lngSumCol As Long ' 合計列の列番号
Dim arrOutput() As Variant ' 出力用二次元配列
Dim arrHeader() As Variant ' ヘッダー出力用一次元配列
Dim arrCol() As String ' 一時列データ配列
Dim rngHeaderStart As Range ' ヘッダー出力開始セル
Dim rngHeaderEnd As Range ' ヘッダー出力終了セル
Dim rngDataStart As Range ' データ出力開始セル
Dim rngDataEnd As Range ' データ出力終了セル
Dim lngCurrentRow As Long ' 現在処理中の行番号
Dim strStartCol As String ' 合計範囲の開始列（列文字）
Dim strEndCol As String ' 合計範囲の終了列（列文字）
Dim strFormula As String ' 合計用数式文字列
On Error GoTo lblErr
With shImport
' インポートシート全体を初期化（既存データを削除）
.Cells.ClearContents
'--------------------------
' ヘッダー出力
'--------------------------
' 構造体配列からヘッダー出力用の配列を作成
ReDim arrHeader(1 To 1, 1 To UBound(arrTypItems))
For lngItemIndex = LBound(arrTypItems) To UBound(arrTypItems)
' 各構造体に格納された項目名をヘッダー用配列に格納
arrHeader(1, lngItemIndex) = arrTypItems(lngItemIndex).strItemName
Next
' ヘッダー出力範囲を変数に格納し、一括出力
' ヘッダー行の出力開始セル（左端）を設定
Set rngHeaderStart = .Cells(ROW_shIMP_HEADER, ROW_shIMP_VALSTART)
' ヘッダー行の出力終了セル（右端）を設定
Set rngHeaderEnd = .Cells(ROW_shIMP_HEADER, ROW_shIMP_VALSTART + UBound(arrTypItems) - 1)
' 構造体から作成した項目名をヘッダー行に一括出力
.Range(rngHeaderStart, rngHeaderEnd).Value = arrHeader
'--------------------------
' 値出力
'--------------------------
' 出力用のデータ配列を初期化（CSV行数×項目数）
ReDim arrOutput(1 To NUM_CSV_ROWS, 1 To UBound(arrTypItems))
' 各項目（列）ごとにCSVデータをデータ配列に転記
For lngItemIndex = LBound(arrTypItems) To UBound(arrTypItems)
' 構造体から対象項目の全行分の値を配列として取得
arrCol = arrTypItems(lngItemIndex).arrStrValues
For lngRow = 1 To NUM_CSV_ROWS
arrOutput(lngRow, lngItemIndex) = arrCol(lngRow)
Next
Next
' データ出力範囲を変数に格納し、一括出力
Set rngDataStart = .Cells(ROW_shIMP_VALSTART, ROW_shIMP_VALSTART)
' データ出力の右下セル（最終行・最終列）を設定
Set rngDataEnd = .Cells(ROW_shIMP_VALSTART + NUM_CSV_ROWS - 1, ROW_shIMP_VALSTART + UBound(arrTypItems) - 1)
' 構造体配列から生成したCSVデータ本体を一括でインポートシートに出力
.Range(rngDataStart, rngDataEnd).Value = arrOutput
'--------------------------
' 合計出力
'--------------------------
' 合計列の列番号を設定（データ列の直後）
lngSumCol = ROW_shIMP_VALSTART + UBound(arrTypItems)
' 合計列のヘッダーに「合計」を出力
.Cells(ROW_shIMP_HEADER, lngSumCol).Value = "合計"
' 各行にSUM関数を設定（A1形式で列名を使用）
For lngRow = 1 To NUM_CSV_ROWS
' 現在処理中の行番号
lngCurrentRow = ROW_shIMP_VALSTART + lngRow - 1
' 列番号を列文字に変換
strStartCol = strGetColumnLetter(ROW_shIMP_VALSTART)
strEndCol = strGetColumnLetter(lngSumCol - 1)
' A1形式での合計範囲の作成
strFormula = "=SUM(" & _
strStartCol & lngCurrentRow _
& ":" & strEndCol & lngCurrentRow & ")"
' セルに数式を設定
.Cells(lngCurrentRow, lngSumCol).Formula = strFormula
Next
End With
' 正常終了時は True を返す
blnWriteImportSheet = True
Exit Function
lblErr:
' エラー発生時のメッセージ表示
MsgBox "インポートシートへの出力中にエラーが発生しました。" & vbCrLf & _
"内容: " & Err.Description, vbExclamation, "blnWriteImportSheet"
blnWriteImportSheet = False
End Function
Excel
コメント