質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.48%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

1374閲覧

【VBA】OpenステートメントでCSVを出力したい

koburon

総合スコア29

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2023/01/25 07:05

前提

VBAでCSVファイルを出力するマクロを作っています。
下記のURLを参考にして作っています。

参考URL:【超簡単】ワンタッチでエクセルからCSV出力するVBAプログラム

該当のソースコード

上記URLのコードをベースにしています。
シートの1行目、2行目を除いて全部で144列を「""」で囲んでCSV出力するように修正しました。

VBA

1Option Explicit 2 3Const EXT As String = ".csv" 4 5Sub CSV出力_詳細指定() 6 Dim Filepath As String 7 Filepath = Application.GetSaveAsFilename(, "CSVファイル(*.csv),*.csv") 8 9 If Filepath = "False" Then 10 End 11 End If 12 13 Call csv.Output(TargetSheet:=ActiveSheet, Filepath:=Filepath, _ 14 StartRow:=3, StartCol:=1, _ 15 WithQuoteCols:=GetSequence(1, 144), _ 16 Charset:="utf-8") 17 18 MsgBox "CSVファイルを「UTF-8」で出力しました。レコード部分のみ出力しています。" 19End Sub

GetSequence

1Public Function GetSequence(minNum As Long, maxNum As Long) As String 2 Dim i As Long 3 For i = minNum To maxNum 4 GetSequence = GetSequence & "," & i 5 Next 6 GetSequence = Mid(GetSequence, 2) 7End Function

「csv.Output」の中身であるモジュールは以下の通りです。

csv.Output

1Option Explicit 2 3'この標準モジュールは変更しない 4 5Enum CSVCols 6 Default = 0 '当初設定に従う 7 force = 1 '強制的に処理を行う 8 Ignore = 2 '処理を行わない 9End Enum

Output

1'CSV出力メインロジック 2'正常終了時TRUEを返す ※現状は、エラー処理を行っていないので常にTRUEが返る 3'※charset に utf-8n と指定すると「BOMなしUTF-8」でCSVデータを作成する 4Function Output(TargetSheet As Worksheet, ByVal Filepath As String, _ 5 Optional ByVal StartRow As Long = 1, Optional ByVal EndRow As Long = 0, _ 6 Optional ByVal StartCol As Long = 1, Optional ByVal EndCol As Long = 0, _ 7 Optional ByVal WithFormatCols As String = "", Optional ByVal WithoutFormatCols As String = "", _ 8 Optional ByVal WithQuoteCols As String = "", Optional ByVal WithoutQuoteCols As String = "", _ 9 Optional ByVal Delimitar As String = ",", Optional ByVal LineEndingCode As String = vbCr & vbLf, _ 10 Optional ByVal QuoteChar As String = """", Optional ByVal CharReplaceQuote As String = """""", _ 11 Optional ByVal Charset As String = "shift_jis") As Boolean 12 13 '出力範囲(行)の指定 14 If EndRow = 0 Then 15 EndRow = getLastRow(TargetSheet) 16 End If 17 18 '出力範囲(列)の設定 19 If EndCol = 0 Then 20 EndCol = getLastColumn(TargetSheet) 21 End If 22 23 '各列出力時の書式付きかどうかの処理方法を配列に格納 24 Dim FormatOptionOfColumns() As Long 25 FormatOptionOfColumns = setOption(WithFormatCols, WithoutFormatCols, StartCol, EndCol) 26 27 '各列出力時に”で囲むかどうかの処理方法を配列に格納 28 Dim QuoteOptionOfColumns() As Long 29 QuoteOptionOfColumns = setOption(WithQuoteCols, WithoutQuoteCols, StartCol, EndCol) 30 31 'CSV出力データ準備 32 Dim csvData As String 33 34 Dim rowData() As String 35 ReDim rowData(0 To EndCol - StartCol) As String 36 37 Dim R As Long 38 Dim c As Long 39 For R = StartRow To EndRow 40 For c = StartCol To EndCol 41 rowData(c - StartCol) = convertFormatTowriteCSVFile(TargetSheet.Cells(R, c), StartCol, _ 42 Delimitar, QuoteChar, CharReplaceQuote, _ 43 FormatOptionOfColumns, QuoteOptionOfColumns) 44 Next 45 46 '1行のデータをデリミタ(区切り文字)でつないで、改行を付加 47 csvData = csvData & Join(rowData, Delimitar) & LineEndingCode 48 Next 49 50'csv出力 51 Output = writeCSVFile(csvData, Filepath, Charset) 52 53End Function

getLastRow

1Private Function getLastRow(TargetSheet As Worksheet) As Long 2 Dim Row As Long 3 Dim Column As Long 4 5'UsedRangeで取得した最下行の右→左、最下行の1段上の右→左と走査していく 6 For Row = TargetSheet.UsedRange.Row + TargetSheet.UsedRange.Rows.Count - 1 To 1 Step -1 7 For Column = TargetSheet.UsedRange.Column + TargetSheet.UsedRange.Columns.Count - 1 To 1 Step -1 8 If TargetSheet.Cells(Row, Column).Value <> "" Then 9 GoTo Finally 10 End If 11 Next 12 Next 13 14Finally: 15 getLastRow = Row 16End Function

getLastColumn

1Private Function getLastColumn(TargetSheet As Worksheet) As Long 2 Dim Row As Long 3 Dim Column As Long 4 5'UsedRangeで取得した最右行の下→上、最右行の1列左の下→上と走査していく 6 For Column = TargetSheet.UsedRange.Column + TargetSheet.UsedRange.Columns.Count - 1 To 1 Step -1 7 For Row = TargetSheet.UsedRange.Row + TargetSheet.UsedRange.Rows.Count - 1 To 1 Step -1 8 If TargetSheet.Cells(Row, Column).Value <> "" Then 9 GoTo Finally 10 End If 11 Next 12 Next 13 14Finally: 15 getLastColumn = Column 16End Function

setOption

1'CSV出力時のオプション 2'(1.書式付で出力するか、2.「”」で囲むかについての設定) 3'を使いやすい形(配列)に格納する 4Private Function setOption(WithCols As String, WithoutCols As String, minCol As Long, maxCol As Long) 5 WithCols = "," & WithCols & "," 6 WithoutCols = "," & WithoutCols & "," 7 8 Dim ret() As Long 9 ReDim ret(0 To maxCol - minCol) 10 11 Dim c As Long 12 For c = LBound(ret) To UBound(ret) 13 If InStr(WithCols, "," & c + 1 & ",") Then 14 ret(c) = CSVCols.force 15 ElseIf InStr(WithoutCols, "," & c + 1 & ",") Then 16 ret(c) = CSVCols.Ignore 17 Else 18 ret(c) = CSVCols.Default 19 End If 20 Next 21 22 setOption = ret 23End Function

convertFormatTowriteCSVFile

1'各セルの値をCSV出力用に加工する 2Private Function convertFormatTowriteCSVFile(R As Range, BaseCol As Long, _ 3 Delimitar As String, QuoteChar As String, CharReplaceQuote As String, _ 4 FormatOptionOfColumns() As Long, QuoteOptionOfColumns() As Long) 5 Dim Val As Variant 6 Val = R.Value 7 8 '書式を適用 9 If FormatOptionOfColumns(R.Column - BaseCol) = CSVCols.force Or _ 10 FormatOptionOfColumns(R.Column - BaseCol) = CSVCols.Default And addFormat(Val) Then 11 Val = R.Text 12 End If 13 14 '「”」で囲む ※データ中に「”」があれば、指定の値に置き換える 15 If QuoteOptionOfColumns(R.Column - BaseCol) = CSVCols.force Or _ 16 QuoteOptionOfColumns(R.Column - BaseCol) = CSVCols.Default And AddQuote(Val, Delimitar, QuoteChar) Then 17 Val = QuoteChar & Replace(Val, QuoteChar, CharReplaceQuote) & QuoteChar 18 End If 19 20 convertFormatTowriteCSVFile = Val 21End Function

addFormat

1'CSVCols.Defaultの場合に、書式を適用するかどうかの判定 2Private Function addFormat(Val As Variant) As Boolean 3 addFormat = False 4End Function

AddQuote

1'CSVCols.Defaultの場合に、「”」で囲むかの判定。 2Private Function AddQuote(Val As Variant, Delimitar As String, QuoteChar As String) As Boolean 3 If InStr(Val, Delimitar) Or InStr(Val, QuoteChar) Or _ 4 InStr(Val, vbLf) Or InStr(Val, vbCr) Then 5 AddQuote = True 6 Else 7 AddQuote = False 8 End If 9End Function

writeCSVFile

1'CSVデータ出力 2'正常終了時TRUEを返す 3Private Function writeCSVFile(csvData As String, Filepath As String, Charset As String) As Boolean 4 Dim removeBom As Boolean 5 6 If Charset = "utf-8n" Then 7 Charset = "utf-8" 8 removeBom = True 9 Else 10 removeBom = False 11 End If 12 13'本来は、下記で変数宣言したいが、参照設定しない場合のために、変数宣言をObjectにする 14' Dim ST As ADODB.Stream 15 Dim ST As Object 16 Set ST = CreateObject("ADODB.stream") 17 18 With ST 19 .Mode = 3 'adModeReadWrite 20 .Type = 2 'adTypeText 21 .Charset = Charset 22 23 .Open 24 .WriteText csvData, 0 'adWriteChar 25 End With 26 27 If removeBom Then 28'以下、Bom抜き処理 29'BOM部分を読み飛ばして、その先から読み込む 30 ST.Position = 0 31 ST.Type = 1 'adTypeBinary 32 ST.Position = 3 33 34'別のストリームにバイナリとしてコピー 35' Dim ST2 As ADODB.Stream 36 Dim ST2 As Object 37 Set ST2 = CreateObject("ADODB.stream") 38 39 With ST2 40 .Mode = 3 'adModeReadWrite 41 .Type = 1 'adTypeBinary 42 .Open 43 44 .Write ST.Read 45 46 .SaveToFile Filepath, 2 'adSaveCreateOverWrite 47 .Close 48 End With 49 Else 50 ST.SaveToFile Filepath, 2 'adSaveCreateOverWrite 51 End If 52 53 ST.Close 54 writeCSVFile = True 55End Function

発生している問題

上記のコードでCSVファイルは問題なく出力できましたが、マクロのレビューを行った際、

「Openステートメント」でレコードをループしてCSVを出力できませんか?」

という提案(注文?)を受けました。
元々URLのソースコードを丸ごとコピー&ペーストして必要な部分を修正しただけな上、「csv.Output」モジュールの詳細が確認できていないため、ロジックがあまり理解できていない状態です。

試したこと

「Openステートメント」「CSV出力」で検索した際、以下のサイトにサンプルコードがあったので、これを現在のCSV出力コードと合わせました。

参考URL:【VBA CSV出力】Openステートメント・FileSystemObject・Streamオブジェクト

Open

1Option Explicit 2 3Const EXT As String = ".csv" 4 5Sub CSV出力_詳細指定() 6 Dim Filepath As String, rs As Recordset 7 Filepath = Application.GetSaveAsFilename(, "CSVファイル(*.csv),*.csv") 8 9 If Filepath = "False" Then 10 End 11 End If 12 13 'Openステートメントを追記(Append)モードで実行します。 14 '追記が不要ならFor Outputを指定します。 15 Open Filepath For Append As #1 16 17 'レコードセットの行数分ループしてテキストファイルに書き込みます。 18 Do Until rs.EOF 19 Print #1, rs(0).Value & "," & rs(1).Value & _ 20 "," & rs(2).Value & "," & rs(3).Value & "," & rs(4).Value 21 rs.MoveNext 22 Loop 23 24 'テキストファイルを閉じます。 25 Close #1 26 27End Sub

エラーメッセージ

上記のコードを実行したところ、エラーが発生しました。

コンパイルエラー: ユーザ定義型は定義されていません。

調べたところ、「recordset」はACCESSで作成したテーブルに対して使用するプロパティのようで、rsの型が定義されていない、という意味だと思います。

実現したいこと

Openステートメントで正しく処理し、かつ前提のコードのように値をすべて「""」で囲んで、書式を「UTF-8」に出力するようにしたいです。
理解できていない部分が多く、調べようとしても何から調べたらいいかもわからない状態なので、ご教示いただければ幸いです。
よろしくお願いいたします。

補足情報(FW/ツールのバージョンなど)

PC:Windows11
ソフト:Microsoft365 Excel

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

hatena19

2023/01/25 08:16

Openステートメントは非常に古くからあるもので、UTF-8出力には対応してません。 VBAでUTF-8出力するなら、ADODB.Streamを使うのがデフォです。 ちなみに、参考URLは Access VBA のサイトなのでrecordsetを使ってるようです。Excelのシートを出力するなら他のサイトを探した方が参考になるでしょう。
tatsu99

2023/01/25 09:19

hatena19さんの指摘通りです。 Openステートメントを使用してUTF-8の文字コード出力はできません。 よって、マクロのレビューの方には、 「OpenステートメントはUTF-8出力には対応していないので、Openステートメントで実装することは不可能です」と回答してください。
koburon

2023/01/26 00:09

>hatena19様 >tatsu99様 コメントありがとうございます。 UTF-8出力には対応していない、ということですね。承知しました。 そのように回答してみます。
guest

回答1

0

自己解決

OpenステートメントはUTF-8出力には対応していないということなので、
レビュー者に回答の上、さらに対応が必要な場合は改めて質問させていただきます。

投稿2023/01/26 00:11

koburon

総合スコア29

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.48%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問