| |
こんなのでも
Option Explicit
Public Sub OutPutCsv()
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
'選択範囲の取得
Set rngTarget = ActiveSheet.UsedRange
'Default出力名の設定
vntFileName = ThisWorkbook.Path & "\" & "TestFile"
'出力名を取得
If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
GoTo ErrorHandler
End If
'ファイルに出力
CsvWrite vntFileName, rngTarget, vbCr
MsgBox "処理が終了しました", vbInformation
ErrorHandler:
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))
'結果変数にフィール文字列を加算
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) & strQuot & 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 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, 2)
If vntFileName = False Then
Exit Function
End If
GetWriteFile = True
End Function
|
|
Hirofumi
- 08/4/25(金) 23:16 -
