| |
全く、質問内容と同じ物では有りませんが
近い物と言う事で参考になるかな？
使い方は、出力したいシートをActiveにします
出力したい範囲を選択して、Sub OutPutCsvScopeを実行するか
其のままSub OutPutCsvScopeを実行して下さい
範囲選択がされていれば其の範囲が、範囲選択がされていなければ、
UsedRangeがInpuBoxに表示されます
この範囲で良ければOkを押します
もし、出力範囲を変更したければこの時点で変更してOkを押して下さい
次に、ファイルを保存ダイアログが表示されますので
ここで、出力ファイル名を選択するか、ファイル名を入力して下さい
Okを出すと出力されます
尚、出力形式は、Csv2形式では、フィールドにカンマ、改行、
ダブルクォーツ等が有る場合フィールドがダブルクォーツで括られます
また、Csv1形式では、文字列の場合無条件で、
フィールドがダブルクォーツで括られます
以下を標準モジュールに記述して下さい
Option Explicit
Public Sub OutPutCsvScope()
Dim vntFileName As Variant
Dim rngTarget As Range
Dim strPrompt As String
Dim strTitle As String
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
'Default出力名の設定
vntFileName = ThisWorkbook.Path & "\" & "TestFile.csv"
'出力名を取得
If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
GoTo ErrorHandler
End If
'ファイルに出力
CsvWrite vntFileName, rngTarget
Beep
MsgBox "処理が終了しました", vbOKOnly, "終了"
ErrorHandler:
'選択範囲の解除
rngTarget(1).Select
Set rngTarget = Nothing
End Sub
Private Sub CsvWrite(ByVal strFileName As String, _
ByVal rngTarget As Range, _
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, ",") & strRetCode
'１レコード書き出し
Print #dfn, strBuf;
Next i
End With
'出力ファイルを閉じる
Close #dfn
End Sub
Private Function ComposeLine(vntField As Variant, _
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形式の出力
' strField = PrepareCsv1Field(vntFieldTmp(1, i))
'Csv2形式の出力
strField = PrepareCsv2Field(vntFieldTmp(1, i))
'結果変数にフィール文字列を加算
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 hh: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 hh: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
|
|
- 04/3/26(金) 22:40 -
