Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


72993 / 76738 ←次へ | 前へ→

【8228】Re:ファイルを出力したいのですが?
回答  ちっくん  - 03/10/4(土) 21:46 -

引用なし
パスワード
   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
>      '1行分のDataをシートから読みこむ
>      vntField = Range(.Offset(i), _
>                .Offset(i, lngColEnd - 1)).Value
>      '出力1レコード作成、書き出し
>      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

0 hits

【8224】ファイルを出力したいのですが? ちっくん 03/10/4(土) 18:18 質問
【8226】Re:ファイルを出力したいのですが? Hirofumi 03/10/4(土) 20:18 回答
【8227】長すぎるとの事で、読み込み側のコード Hirofumi 03/10/4(土) 20:20 回答
【8238】ありがとうございます ちっくん 03/10/5(日) 22:42 お礼
【8228】Re:ファイルを出力したいのですが? ちっくん 03/10/4(土) 21:46 回答

72993 / 76738 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free