| |
選択範囲をCSV出力するコードです
この中の、Csv2形式の出力は、
特殊文字を含まない文字列フィールドも、ダブルクォーツで括りません
Option Explicit
Public Sub OutPutCsv()
Dim vntFileName As Variant
Dim rngTarget As Range
Dim strPrompt As String
Dim strTitle As String
Dim blnCsv1 As Boolean
strPrompt = "Csv出力するRangeを選択して下さい"
strTitle = "Csv出力"
On Error GoTo ErrorHandler
'選択範囲の取得
With Application
'もし、選択範囲が無いなら
If .Selection.Count = 1 Then
Set rngTarget = ActiveSheet.UsedRange
Else
Set rngTarget = .Selection
End If
'選択範囲の取得
Set rngTarget = .InputBox(Prompt:=strPrompt, _
Title:=strTitle, _
Default:=rngTarget.Address, _
Type:=8)
rngTarget.Select
End With
'出力形式の選択
If MsgBox("CSV1形式出力を行います" & vbCrLf _
& " CSV1形式 = はい" & vbCrLf _
& " CSV2形式 = いいえ", _
vbYesNo + vbDefaultButton2 + vbQuestion, _
"出力形式選択") = vbYes Then
blnCsv1 = True
End If
'Default出力名の設定
' vntFileName = ThisWorkbook.Path & "\" & "TestFile.csv"
'出力名を取得
If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
GoTo ErrorHandler
End If
'ファイルに出力
CsvWrite vntFileName, rngTarget, blnCsv1
Beep
MsgBox "処理が終了しました", vbOKOnly, "終了"
ErrorHandler:
'選択範囲の解除
rngTarget(1).Select
Set rngTarget = Nothing
End Sub
Private Sub CsvWrite(ByVal strFileName As String, _
ByVal rngTarget As Range, _
Optional blnCsv1 As Boolean = False, _
Optional strRetCode As String = vbCrLf)
Dim dfn As Integer
Dim i As Long
Dim j As Long
Dim strBuf As String
Dim lngCount As Long
Dim vntField As Variant
'空きファイル番号を取得します
dfn = FreeFile
'出力ファイルをOpenします
Open strFileName For Output As dfn
With rngTarget
lngCount = .Columns.Count
For i = 1 To .Rows.Count
'１行分のDataをシートから読みこむ
vntField = .Item(i, 1).Resize(, lngCount)
'出力１レコード作成
strBuf = ComposeLine(vntField, blnCsv1, ",") _
& strRetCode
'１レコード書き出し
Print #dfn, strBuf;
Next i
End With
'出力ファイルを閉じる
Close #dfn
End Sub
Private Function ComposeLine(vntField As Variant, _
Optional blnCsv1 As Boolean = False, _
Optional strDelim As String = ",") As String
' レコード作成
Dim i As Long
Dim strResult As String
Dim strField As String
Dim lngFieldEnd As Long
Dim vntFieldTmp As Variant
'もし、データが複数なら
If VarType(vntField) = vbArray + vbVariant Then
vntFieldTmp = vntField
Else
ReDim vntFieldTmp(1 To 1, 1 To 1)
vntFieldTmp(1, 1) = vntField
End If
'データ数の取得
lngFieldEnd = UBound(vntFieldTmp, 2)
'データ数繰り返し
For i = 1 To lngFieldEnd
'もし、Csv1出力の場合
If blnCsv1 Then
strField = PrepareCsv1Field(vntFieldTmp(1, i))
Else
strField = PrepareCsv2Field(vntFieldTmp(1, i))
End If
'結果変数にフィール文字列を加算
strResult = strResult & strField
'データカウントがデータ数未満の場合
If i < lngFieldEnd Then
'区切り文字を結果変数に加算
strResult = strResult & strDelim
End If
Next i
ComposeLine = strResult
End Function
Private Function PrepareCsv1Field(ByVal vntValue As Variant) As String
' Csv1出力形式の調整
Dim i As Long
Dim lngPos As Long
Const strQuot As String = """"
'引数の変数内部形式に就いて
Select Case VarType(vntValue)
Case vbString '文字列型
'ダブルクォーツの処理
i = 1
lngPos = InStr(i, vntValue, strQuot, vbBinaryCompare)
Do Until lngPos = 0
vntValue = Left(vntValue, lngPos) & Mid(vntValue, lngPos + 1)
i = lngPos + 2
lngPos = InStr(i, vntValue, strQuot, vbBinaryCompare)
Loop
'両端にダブルクォーツを付加
vntValue = strQuot & vntValue & strQuot
Case vbDate '日付型
'日付が時分秒を持つなら
If TimeValue(vntValue) > 0 Then
vntValue = Format(vntValue, "yyyy/mm/dd h:mm:ss")
Else
vntValue = Format(vntValue, "yyyy/mm/dd")
End If
End Select
PrepareCsv1Field = CStr(vntValue)
End Function
Private Function PrepareCsv2Field(ByVal vntValue As Variant) As String
' Csv2出力形式の調整
Dim i As Long
Dim blnQuot As Boolean
Dim lngPos As Long
Const strQuot As String = """"
'引数の変数内部形式に就いて
Select Case VarType(vntValue)
Case vbString '文字列型
'ダブルクォーツの処理
i = 1
lngPos = InStr(i, vntValue, strQuot, vbBinaryCompare)
Do Until lngPos = 0
vntValue = Left(vntValue, lngPos) & Mid(vntValue, lngPos + 1)
i = lngPos + 2
lngPos = InStr(i, vntValue, strQuot, vbBinaryCompare)
Loop
'ダブルクォーツで括るか否かの判断処理
For i = 1 To 5
lngPos = InStr(1, vntValue, Choose(i, ",", strQuot, _
vbCr, vbLf, vbTab), vbBinaryCompare)
If lngPos <> 0 Then
blnQuot = True
Exit For
End If
Next i
'ダブルクォーツで括るの判断の場合
If blnQuot Then
vntValue = strQuot & vntValue & strQuot
End If
Case vbDate '日付型
'日付が時分秒を持つなら
If TimeValue(vntValue) > 0 Then
vntValue = Format(vntValue, "yyyy/mm/dd h:mm:ss")
Else
vntValue = Format(vntValue, "yyyy/mm/dd")
End If
End Select
PrepareCsv2Field = CStr(vntValue)
End Function
Private Function GetWriteFile(vntFileName As Variant, _
Optional strFilePath As String) As Boolean
Dim strFilter As String
Dim strInitialFile As String
'フィルタ文字列を作成
strFilter = "CSV File (*.csv),*.csv," _
& "Text File (*.txt),*.txt"
'既定値のファイル名を設定
strInitialFile = vntFileName
'読み込むファイルの有るフォルダを指定
If strFilePath <> "" Then
'ファイルを開くダイアログ表示ホルダに移動
ChDrive Left(strFilePath, 1)
ChDir strFilePath
End If
'「ファイルを保存」ダイアログを表示
vntFileName _
= Application.GetSaveAsFilename(vntFileName, strFilter, 1)
If vntFileName = False Then
Exit Function
End If
GetWriteFile = True
End Function
|
|
Hirofumi
- 04/9/5(日) 16:37 -
