| |
▼Hirofumi さん：
>ダブルクォーツ無しで出力する事は、こんなコードで出来るけど
>データの中に、ダブルクォーツや、改行、カンマが有ると、
>読み込む時に、元の様に成らないよ？
>
>出力したいシートでマクロを起動すると
>UsedRangeが選択され、UsedRangeの範囲を表示したInputBoxが表示されます
>ここで、出力範囲を変更するなら、範囲を選択し直して下さい
>Okを出すと、保存のダイアログが出ますので、出力名を決めてOkを出すと
>Csv出力されます
>
>以下を標準モジュールに記述して下さい
>
>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 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
> '結果変数にフィール文字列を加算
> strResult = strResult & CStr(vntFieldTmp(1, i))
> 'データカウントがデータ数未満の場合
> If i < lngFieldEnd Then
> '区切り文字を結果変数に加算
> strResult = strResult & strDelim
> End If
> Next i
>
> ComposeLine = strResult
>
>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/5/30(日) 15:36 -
