| |
何か、肝心な部分が書かれて居ないので、善く説明が解らないのですが？
よって、私が使っているCSV出力のコードを載せて置きます
以下のコードは、シートの決められた列数を最終行までCSV出力します
提示したコードは、ActiveSheetをLfを改行コードとし、先頭から15列出力します
もし、シート、列数等を変更したい場合は、以下の数値等を変更して下さい
'ファイル出力するシートの参照
Set wksRead = ActiveSheet
'ファイル出力する先頭行の値
lngReadRow = 1
'ファイル出力する先頭列の値
lngReadCol = 1
'ファイル出力する最終列の値
lngReadCalEnd = 15
'以下を標準モジュールに記述して下さい
Option Explicit
Public Sub WriteCsvSequ()
Dim vntFileName As Variant
Dim wksRead As Worksheet
Dim lngReadRow As Long
Dim lngReadCol As Long
Dim lngReadCalEnd As Long
'出力名を取得します
If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
Exit Sub
End If
'ファイル出力するシートの参照
Set wksRead = ActiveSheet
'ファイル出力する先頭行の値
lngReadRow = 1
'ファイル出力する先頭列の値
lngReadCol = 1
'ファイル出力する最終列の値
lngReadCalEnd = 15
'ファイルに出力
CsvWrite vntFileName, vbLf, wksRead, _
lngReadRow, lngReadCol, lngReadCalEnd
'読み込むシートの参照を破棄
Set wksRead = Nothing
Beep
MsgBox "処理が終了しました", vbOKOnly, "終了"
End Sub
Private Sub CsvWrite(ByVal strFileName As String, _
strRetCode As String, _
ByVal wksRead As Worksheet, _
lngRowTop As Long, _
lngColTop As Long, _
lngColEnd As Long)
Dim dfn As Integer
Dim i As Long
Dim j As Long
Dim lngRowEnd As Long
Dim strBuf As String
Dim vntField As Variant
'読み込み最終行を取得
With wksRead
lngRowEnd = .Cells(65536, lngColTop).End(xlUp).Row
End With
'空きファイル番号を取得します
dfn = FreeFile
'出力ファイルをOpenします
Open strFileName For Output As dfn
With wksRead.Cells(lngRowTop, lngColTop)
For i = 0 To lngRowEnd - lngRowTop
'１行分のDataをシートから読みこむ
vntField = Range(.Offset(i), _
.Offset(i, lngColEnd - 1)).Value
'出力１レコード作成
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
lngFieldEnd = UBound(vntField, 2)
For i = 1 To lngFieldEnd
strResult = strResult & PrepareCsvField(vntField(1, i))
If i < lngFieldEnd Then
strResult = strResult & strDelim
End If
Next i
ComposeLine = strResult
End Function
Private Function PrepareCsvField(ByVal _
strValue As String) As String
' フィールドのダブルクォーツ付加
Dim i As Long
Dim blnQuot As Boolean
Dim lngPos As Long
Const strQuot As String = """"
If Left(strValue, 1) = "'" Then
strValue = Mid(strValue, 2)
End If
i = 1
lngPos = InStr(i, strValue, strQuot, vbBinaryCompare)
Do Until lngPos = 0
strValue = Left(strValue, lngPos) _
& Mid(strValue, lngPos + 1)
i = lngPos + 2
lngPos = InStr(i, strValue, strQuot, vbBinaryCompare)
Loop
For i = 1 To 5
lngPos = InStr(1, strValue, Choose(i, ",", strQuot, _
vbCr, vbLf, vbTab), vbBinaryCompare)
If lngPos <> 0 Then
blnQuot = True
Exit For
End If
Next i
If blnQuot Then
strValue = strQuot & strValue & strQuot
End If
PrepareCsvField = strValue
End Function
Private Function GetWriteFile(vntFileName As Variant, _
Optional strFilePath As String) As Boolean
Dim i As Long
Dim strFilter As String
Dim strInitialFile As String
'フィルタ文字列を作成
For i = 1 To 2
strFilter _
= strFilter & Choose(i, "CSV File (*.csv),*.csv,", _
"Text File (*.txt),*.txt")
Next i
'既定値のファイル名を設定
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
|
|
- 03/9/11(木) 21:49 -
