ExcelファイルをＣＳＶファイルに分割する
EXCELで作成したデータをCSVファイルに分割するサンプルアプリを紹介します。
今回紹介するアプリはデータとして持っている会社名をもとに、会社別にＣＳＶファイル作成するVBAです。
会社名順にソートしたデータを上から順番に処理して、会社名が変わったところで次のＣＳＶファイルを作成する処理です。
業務の中で、一つのファイルを部署ごとや取引会社ごとにに分けてデータを処理する際に活用できるサンプルコードです。
各メソッドの説明
１． Openステートメント
ファイルパスにファイルが存在した場合はファイルを開き、なかった場合は新規作成します。
ファイルパスで指定したファイルが存在しない場合は、ファイルを新規作成します。Outputは全てのデータを消して上書きするという意味で、Append にするとデータを残しつつ最終行に追加することもできます。また、#番号はファイルを開いたときにつける番号です。
この番号に対して、PrintやCloseを指定することで、同じファイルに対してデータ入力、ファイルを閉じるなどの操作をすることができます。
Open ファイルパス For Output As #番号
２．Printステートメント
#番号はOpenで指定した番号と同じ番号を入力します。
その後、カンマ(,)で区切って値を入力するとデータを書き込むことができます。
また、Printステートメントの代わりにWrite # ステートメントを使うと、文字列がダブルクォーテーションで括られて出力されます。
通常はこのPrint文またはWrite文を、While文またはFor文でループ処理してデータを入力します。
Print #番号, ファイルに書き込む値 (X1, X2, X3, X4, X5, X6)
３．Closeステートメント
Openで指定した番号をCloseの後に入力することで、保存してファイルを閉じることができます。
Close #番号
サンプルコードの処理内容
「CSVファイルに分割」ボタンをクリックすると、表の内容が会社別のCSVファイルに分割されます。
サンプルコード コードの作成手順はこちら
Sub Export_CSVFile()
Const cnsTitle = "CSVファイル出力" 'ダイアログのタイトル
Dim xlAPP As Application 'Excel.Applicationオブジェクト
Dim intFF As Integer 'FreeFile値
Dim strFileName As String 'Open（出力）するファイル名（フルパス）
Dim varFileName As String 'ファイル名受取り用
Dim X(1 To 10) As Variant '書き出すレコード内容
Dim lngRow As Long '収容するセルの行
Dim rowLast As Long 'データが収容された最終行
Dim recCnt As Long 'レコード件数カウンタ
Dim col As Long 'カラム
Dim xPath As String '出力先のパス
Dim fil As String '分割ファイル識別フラグ
'ワークシート名セット
Dim ws As Worksheet
Set ws = Worksheets("sheet1")
'Applicationオブジェクト取得
Set xlAPP = Application
'ステータスバーに「作成中」を表示
xlAPP.StatusBar = "ファイル作成中"
'出力先のパスを指定
With ActiveWorkbook
xPath = .Path & "\"
End With
'ファイル名に付ける日付を取得
Dim strDate As String
strDate = DateSerial(Year(Now), Month(Now), 1)
strDate = Format(strDate, "yyyymm")
rowLast = ws.Cells(Rows.Count, 2).End(xlUp).Row 'B列最終行を取得
If rowLast < 5 Then 'データがない場合は出力しない
xlAPP.StatusBar = False
MsgBox "出力出来るデータがありません。", , cnsTitle
Exit Sub
End If
lngRow = 5 '開始行
fil = "C" '分割ファイル識別フラグを指定
'最終行まで繰り返す
Do Until lngRow > rowLast
'csv出力
varFileName = xPath & "\" & ws.Cells(lngRow, 2).Value & "" & strDate & ".csv"
strFileName = varFileName
'fil変数がＣなら別のCSVファイルを作成
If fil = "C" Then
'使用可能なファイル番号を取得(以降この値で入出力する)
intFF = FreeFile
'指定ファイルをOpen(出力ﾓｰﾄﾞ)
Open strFileName For Output As #intFF
'タイトル行
Write #intFF, "会社名", "注文番号", "品名", "数量", "単価", "金額"
'fil変数の値を解除
fil = ""
End If
Erase X ' 配列要素を初期化
'CSVテキスト項目に出力できない文字を除去する
'1列～７列目のデータを一ずつ取り出してループ処理
For col = 1 To 7
X(col) = FP_CutInjusticeChar(ws.Cells(lngRow, col).Value) '当コードの下に記載したサブルーチンを参照
Next col
'レコード件数カウンタの加算
recCnt = recCnt + 1
xlAPP.StatusBar = "出力中です．．．．(" & recCnt - 1 & "レコード目)"
'レコードを出力
Write #intFF, X(2), X(3), X(4), X(5), X(6), X(7)
'会社名が異なったら一旦CSVファイルをクローズして終了
If ws.Cells(lngRow, 2).Value <> ws.Cells(lngRow + 1, 2).Value Then
Close #intFF '指定ファイルをClose
fil = "C" '別の分割ファイルを作成
End If
NE:
lngRow = lngRow + 1 '次の行へ
Loop
'ステータスバーを非表示にする
xlAPP.StatusBar = False
'終了メッセージ
MsgBox "ファイル出力が完了しました。" & vbCr & _
"レコード件数=" & recCnt - 1 & "件", vbInformation, cnsTitle
End Sub
■ FP_CutInjusticeChar サブルーチン
'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 = "" '変数を一旦空にする
'Excelセル内の文字数分を繰り返す
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