| |
こんな物を欲しているのかな？
誰かもっと簡単なコードを教えてくれると思うけど？
取り合えず、ActiveSheetのA1〜D15をCSVファイルに出力するコードと
出力したファイルをActiveSheetの指定位置に読み込むコードにして見ました
ファイル出力は、以下のコードの値の変更で出力する部分が変わります
'出力先頭行の初期値設定
lngReadRow = 1
'出力最終行の値設定
lngReadRowEnd = 15
'出力先頭列の値設定
lngReadCol = 1
'出力最終列の値設定
lngReadCalEnd = 4
'出力するシートの参照を設定
Set wksRead = ActiveSheet
以下を標準モジュールに記述して下さい
'ファイル出力のコード
Option Explicit
Public Sub WriteCsvSequ()
Dim vntFileName As Variant
Dim wksRead As Worksheet
Dim lngReadRow As Long
Dim lngReadRowEnd As Long
Dim lngReadCol As Long
Dim lngReadCalEnd As Long
'出力名を取得します
If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
Exit Sub
End If
'出力先頭行の初期値設定
lngReadRow = 1
'出力最終行の値設定
lngReadRowEnd = 15
'出力先頭列の値設定
lngReadCol = 1
'出力最終列の値設定
lngReadCalEnd = 4
'出力するシートの参照を設定
Set wksRead = ActiveSheet
'ファイルに出力
CsvWrite vntFileName, wksRead, lngReadRow, _
lngReadRowEnd, lngReadCol, lngReadCalEnd
'読み込むシートの参照を破棄
Set wksRead = Nothing
Beep
MsgBox "処理が終了しました", vbOKOnly, "終了"
End Sub
Private Sub CsvWrite(ByVal strFileName As String, _
ByVal wksRead As Worksheet, _
lngRowTop As Long, _
lngRowEnd As Long, _
lngColTop As Long, _
lngColEnd As Long)
Dim dfn As Integer
Dim i As Long
Dim j As Long
Dim vntField As Variant
'空きファイル番号を取得します
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
'出力１レコード作成、書き出し
Print #dfn, ComposeLine(vntField, ",")
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
|
|
Hirofumi
- 03/10/4(土) 20:18 -
