カテゴリー
Microsoft

【Excel VBA】【2】CSV ファイルを指定ブックのシートにテキスト形式でインポートするクラスのコード♪

ポイント

  • CSV 形式のファイル、つまりカンマで区切られたデータのファイルを読み込むことができる。ファイル拡張子が .csv でなくても読み込める。
  • 必ずテキスト形式でインポートされるように TextFileColumnDataTypes に指定する配列の作り方を工夫した。
  • コネクションは生成されたものだけ削除するように改善した。
  • Name オブジェクトの削除方法を改善し、シート名に影響を受けないようにした。
  • 他のエクセルなどからも呼び出せるようにブック名を指名するようにした。

読み込まれる CSV ファイル

これは前回と同じです。

No,氏名,電話番号
1,伊藤健一,0112223333
2,高橋哲也,0114445555
3,佐藤誠,0116667777

VBA コード

''' <summary>
''' CSV ファイルを指定ブックのシートにインポートするクラスです。
''' エクセルへはテキスト形式で書き込みます。
''' </summary>

Option Explicit

Private mstrCsvFilePath As String
Private mstrBook As String
Private mobjSheet As Worksheet
Private mstrStartCell As String
Private mstrAutoCreatedName As String

''' <summary>
''' コンストラクタ
''' </summary>
Private Sub Class_Initialize()
  ' インポート時にセル範囲に付く「名前」
  ' 既存の Name オブジェクトと重複しないよう、年月日時分秒の文字列を末尾に付加
  Dim strSalt as String: strSalt = Format(Now, "yyyymmddhhnnss")
  mstrAutoCreatedName = "CsvImporterName" & strSalt
End Sub

''' <summary>
''' 初期化処理を実行します。
''' </summary>
''' <param name="strCsvFilePath">CSV ファイルフルパス</param>
''' <param name="strBook">書き込み対象ブック名</param>
''' <param name="strSheet">書き込み対象ワークシート名</param>
''' <param name="strStartCell">インポート開始セル名</param>
Public Sub Init( _
  ByVal strCsvFilePath as String, _
  ByVal strBook as String, _
  ByVal strSheet As String, _
  ByVal strStartCell As String)
  ' 変数をセット
  mstrCsvFilePath = strCsvFilePath
  Set mobjSheet = Workbooks(strBook).Sheets(strSheet)
  mstrStartCell = strStartCell
End Function

''' <summary>
''' CSV ファイルを読み込み、ワークシートに書き込みます。
''' </summary>
Public Sub Import()
  ' ファイルの各列に適用されるデータ型をテキスト形式のみに指定
  Dim vntColDataTypes() As Variant, i As Long: ReDim vntColDataTypes(Column.Count)
  For i = 0 To Column.Count: vntColDataTypes(i) = xlTextFormat: Next i

  ' ファイル読み込み、および、書き込み
  With mobjSheet.QueryTables.Add( _
    Connection:="Text;" & mstrCsvFilePath, _
    Destination:=mobjSheet.Range(mstrStartCell))
    .Name = mstrAutoCreatedName
    .RowNumbers = False
    .RefreshStyle = xlOverwriteCells
    .SavePassword = False
    .SaveData = True
    .RefreshPeriod = 0
    .TextFilePlatform = 932
    .TextFileCommaDelimiter = True
    .TextFileColumnDataTypes = vntColDataTypes
    .TextFileTrailingMinusNumbers = True
    .Refresh BackgroundQuery:=False
    Dim strConName As String: strConName = .WorkbookConnection.Name
  End With

  ' 後処理。作成されるコネクションと Name オブジェクトを削除
  Call DeleteConnection(mstrBook, strConName)
  Call DeleteName(mstrBook, mstrAutoCreatedName)
End Sub

''' <summary>
''' 指定したコネクションを削除します。
''' </summary>
''' <param name="strBook">ブック名文字列</param>
''' <param name="strConName">コネクション名文字列</param>
Private Sub DeleteConnection( _
  ByVal strBook As String, _
  ByVal strConName As String)
  Workbooks(strBook).Connections(strConName).Delete
End Sub

''' <summary>
''' 指定した名前 (Name オブジェクト) を削除します。
''' </summary>
''' <param name="strBook">ブック名文字列</param>
''' <param name="strName">名前 (Name オブジェクト) 文字列</param>
Private Sub DeleteName( _
  ByVal strBook As String, _
  ByVal strName As String)
  ' シート名が [Sheet1!] など ! を含む場合、Name を指定しての削除ができずエラーとなった。
  ' よって、Name に対応する Index を取得し、Index を指定して削除する。

  ' 削除対象の Name オブジェクトを特定
  Dim colIndexes As Collection: Set colIndexes = New Collection
  Dim vntItem As Variant
  For Each vntItem In Workbooks(strBook).Names
      If vntItem.Name Like "*" & strName & "*" Then
          Call colIndexes.Add(vntItem.Index)
      End If
  Next vntItem

  ' 特定した Name オブジェクトを削除
  Dim vntIndex As Variant
  For Each vntIndex In colIndexes
     Workbooks(strBook).Names.Item(vntIndex).Delete
  Next vntIndex
End Sub

続いては上記のクラスを確認するコードです。CSV のインポート先は VBA のエクセルファイル自身としています。

Option Explicit

Public Sub Test()
  ' 準備
  ' CSV ファイルパス取得
  Dim strCsvFilePath As String
  strCsvFilePath = Application.GetOpenfilename( _
    Filefilter:="CSVファイル(*.csv),*.csv", _
    Title:="CSVファイルの選択")
  If strCsvFilePath = "False" Then
    Debug.Print ("CSV ファイルが指定されなかったため、終了")
    End
  End If

  ' CSV インポート
  Dim udtCi As CsvImporter: Set udtCi = New CsvImporter
  Call udtCi.Init(strCsvFilePath, "VbaCsvImporter.xlsm" "Sheet1", "A1")
  Call udtCi.Import
End Sub

おわりに

参考ページです。ありがとう存じます！

以前の投稿のコードをベースにしましたけれども、タイポなどがあり直すこともできました。一石二鳥ですの♪

以上です。

コメントを残す