EXCEL VBA – ワークシートから汎用CSVデータに出力する

EXCEL
この記事は約6分で読めます。
スポンサーリンク

エクセルワークシートからCSVに書き出すVBAコードです。
私の場合は、例えば基幹業務において、Excelから奉行シリーズが受け入れる汎用データを出力するために活用しました。

スポンサーリンク

やりたいこと

  • ExcelシートからCSVファイルを書き出したい。
  • 「名前を付けて保存」ダイアログボックスを表示して、任意の場所に任意のファイル名で書き出したい。
  • デフォルトのファイル名は現在日時とする。
  • 奉行シリーズの場合、1行目に受入記号が入るので、1行目から書き出す。
  • 2行に満たない場合(中身データがない場合)は書き出さない。
  • レコード数のカウントは2行目からとする。

というわけで、まず、下記コードをベースとしました。

Option Explicit

'###### 汎用CSV出力 ######
Sub Export_CSVFile()
 Const cnsTitle = "CSVファイル出力" '「名前を付けて保存」ダイアログのタイトル
 Const cnsFilter = "CSVファイル (*.csv),*.csv"
 Dim xlAPP As Application 'Excel.Applicationオブジェクト
 Dim intFF As Integer 'FreeFile値
 Dim strFileName As String 'Open(出力)するファイル名(フルパス)
 Dim varFileName As Variant 'ファイル名受取り用
 Dim X(1 To 10) As Variant '書き出すレコード内容
 Dim lngRow As Long '収容するセルの行
 Dim rowLast As Long 'データが収容された最終行
 Dim recCnt As Long 'レコード件数カウンタ
 Dim col As Long 'カラム

 Dim ws As Worksheet
 Set ws = Worksheets("Sheet1")
    
 'Applicationオブジェクト取得
 Set xlAPP = Application
 '「名前を付けて保存」ダイアログでステータスバーにファイル名の指定を受ける
 xlAPP.StatusBar = "出力するファイル名を指定して下さい。"
 
 '現在日時をファイル名のデフォルト値に
 Dim strDate As String
 strDate = Format(Now, "yyyymmdd-hhnnss")
 varFileName = xlAPP.GetSaveAsFilename( _
  InitialFileName:=strDate & ".csv", _
  fileFilter:=cnsFilter, _
  Title:=cnsTitle)
 'キャンセルされた場合はFalseが返るので処理中止
 If VarType(varFileName) = vbBoolean Then
  xlAPP.StatusBar = False
  Exit Sub
 End If
    
 strFileName = varFileName
 
 rowLast = ws.Cells(Rows.Count, 1).End(xlUp).row 'A列最終行を取得
    
 If rowLast <2 then '2行に満たない場合は出力しない xlapp.statusbar = False   msgbox "出力出来るデータがありません。", , cnstitle exit sub end if 'freefile値の取得(以降この値で入出力する) intff = FreeFile  '指定ファイルをopen(出力モード) open strfilename for output as #intff '開始行 lngrow  '最終行まで繰り返す do until> rowLast
  Erase X ' 初期化
  'A~J列内容をレコードにセット(先頭は1行目)
  For col = 1 To 10
   X(col) = FP_CutInjusticeChar(ws.Cells(lngRow, col).Value)
  Next col
  'レコード件数カウンタの加算
  recCnt = recCnt + 1
  xlAPP.StatusBar = "出力中です....(" & recCnt - 1 & "レコード目)"
  'レコードを出力
  Write #intFF, X(1), X(2), X(3), X(4), X(5), X(6), X(7), X(8), X(9), X(10)
  '行を加算
  lngRow = lngRow + 1
 Loop
 '指定ファイルをClose
 Close #intFF
 xlAPP.StatusBar = False
 '終了メッセージ
 MsgBox "ファイル出力が完了しました。" & vbCr & _
  "レコード件数=" & recCnt - 1 & "件", vbInformation, cnsTitle
End Sub

'CSVテキスト項目に出力できない文字を除去する
Private Function FP_CutInjusticeChar(varInText As Variant) As Variant
 Dim strInText As String
 Dim POS As Long
 Dim strChar As String
 Dim strOutText As String
    
 FP_CutInjusticeChar = Empty
 '一旦、文字列に変換する
 strInText = Trim$(CStr(varInText))
 'ブランクの場合は処理なし
 If strInText = "" Then Exit Function
    
 '文字列の桁数分繰り返す
 strOutText = ""
 For POS = 1 To Len(strInText)
  '1文字を取り出す
  strChar = Mid(strInText, POS, 1)
  'ダブルクォーテーションとCRコードを省く
  If ((strChar <> vbCr) And (strChar <> """")) Then
   strOutText = strOutText & strChar
  End If
 Next POS
 FP_CutInjusticeChar = strOutText
End Function

奉行シリーズの汎用データを確認しますと、時間など数値の場合はダブルクォーテーションで括ってない場合があったので、その対応として、書き出し元のワークシートに応じて「レコードの出力」部のコードを、Write #ステートメントと Print #ステートメントの使い分けとしました(Write #ステートメントのみで書き出したデータでも奉行シリーズ側が受け入れる可能性はありますが…)。
Write #ステートメントは自動的にダブルクォーテーションで括って書き出しますが、Print #ステートメントはそのままの状態でテキストとして書き出します。
下記コードは、1行目はダブルクォーテーションで括り、2行目以降はダブルクォーテーション有り無し混在としています。

'レコードを出力
If lngRow = 1 Then
 Write #intFF, X(1), X(2), X(3), X(4), X(5), X(6), X(7), X(8), X(9), X(10)
Else
 Print #intFF, """"; X(1); """"; ","; X(2); ","; X(3); ","; X(4); ","; X(5); ","; X(6); ","; X(7); ","; X(8); ","; X(9); ","; X(10)
End If

以上、ご参考になれば幸いです。
以下のページを参考にさせていただきました。ありがとうございます。

VBA応用(CSV形式テキストデータの書き出し)
EXCEL
スポンサーリンク
スポンサーリンク
J.をフォローする
スポンサーリンク
アトリエJ.

コメント

  1. 吉岡 より:

    お手本にさせていただいております。

    EXCEL VBA – ワークシートから汎用CSVデータに出力する件に関してご質問がございます。

    保存されたcsvファイルを確認したところ、A列~J列までしか保存されておりませんでした。
    A列~CZ列まで抽出して保存する方法はございますでしょうか?
    ご教示いただけますと幸いです。
    よろしくお願い致します。

  2. J.J. より:

    コメントありがとうございます。
    説明不足ですみません。

    Dim X(1 To 10) As Variant で定義しているのが列数になりますので、CZ列までですと、(1 To 104)となります。
    同様に、For col = 1 To 10 → For col = 1 To 104
    Write #intFF, X(1), X(2), X(3), X(4), X(5), X(6), X(7), X(8), X(9), X(10) → X(104)まで書きます。
    試していただけますでしょうか。

タイトルとURLをコピーしました