| |
指定範囲をCsv出力するマクロです
多分此れでも出力出きると思います？
Option Explicit
Public Sub OutPutCsv()
Dim vntFileName As Variant
Dim rngTarget As Range
Dim strPrompt As String
Dim strTitle As String
Dim strMessage As String
strPrompt = "Csv出力するRangeを選択して下さい"
strTitle = "Csv出力"
strMessage = "処理を中止します"
On Error GoTo Wayout
'選択範囲の取得
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
On Error GoTo 0
'Default出力名の設定
' vntFileName = ThisWorkbook.Path & "\" & "TestFile.csv"
'出力名を取得
If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
strMessage = "マクロがキャンセルされました"
GoTo Wayout
End If
'ファイルに出力
CsvWrite vntFileName, rngTarget
strMessage = "処理が終了しました"
Wayout:
'選択範囲の解除
rngTarget(1).Select
Set rngTarget = Nothing
MsgBox strMessage, vbInformation
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
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 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
- 06/4/19(水) 20:19 -
