| |
Hirofumi さんありがとうございます。早速ためさせていただきます。
>こんな物を欲しているのかな？
>誰かもっと簡単なコードを教えてくれると思うけど？
>取り合えず、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
|
|
ちっくん
- 03/10/4(土) 21:46 -
