Excel VBA質問箱 IV

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

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


12869 / 13646 ツリー ←次へ | 前へ→

【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 回答

【8224】ファイルを出力したいのですが?
質問  ちっくん  - 03/10/4(土) 18:18 -

引用なし
パスワード
   本当はそのままエクセルで保存をすれば済む話なんでしょうけど本体ファイルサイズが大きいためデーター入力欄だけを任意ファイルに保存、読み込みをしたいのですがVBAでどのように記述をしたらよいかわかりません。
たとえばセルA1からD15までのデーターを(数値)を別ファイルに保存、読み込
別ファイル→*.dat みたいにファイルを出力・読み込み
教えてくださいよろしくお願いします。

【8226】Re:ファイルを出力したいのですが?
回答  Hirofumi E-MAIL  - 03/10/4(土) 20:18 -

引用なし
パスワード
   こんな物を欲しているのかな?
誰かもっと簡単なコードを教えてくれると思うけど?
取り合えず、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

【8227】長すぎるとの事で、読み込み側のコード
回答  Hirofumi E-MAIL  - 03/10/4(土) 20:20 -

引用なし
パスワード
   長すぎるとの事で、読み込み側のコードです

ファイルの読み込みは、以下のコードの値の変更で読み込み位置が変わります

  '書き込み先頭行の初期値設定
  lngReadRow = 1
  '書き込み先頭列の初期値設定
  lngReadCol = 1
  '書き込むシートの参照を設定
  Set wksWrite = ActiveSheet

以下を標準モジュールに記述して下さい

'ファイルの読み込みのコード
Option Explicit

Public Sub ReadCsvSequ()

  Dim i As Long
  Dim vntFileName As Variant
  Dim wksWrite As Worksheet
  Dim lngReadRow As Long
  Dim lngReadCol As Long
  
  '読み込むファイル名を取得
  If Not GetReadFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If
  
  '書き込み先頭行の初期値設定
  lngReadRow = 1
  '書き込み先頭列の初期値設定
  lngReadCol = 1
  '書き込むシートの参照を設定
  Set wksWrite = ActiveSheet
  
  'ファイルを読み込みシートに書き込む
  CSVRead vntFileName, wksWrite, lngReadRow, lngReadCol
  
  '書き込むシートの参照を破棄
  Set wksWrite = Nothing
  
  Beep
  MsgBox "処理が終了しました", vbOKOnly, "終了"
 
End Sub

Private Sub CSVRead(ByVal strFileName As String, _
              ByVal wksWrite As Worksheet, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1)
  
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strLine As String
  Dim blnMulti As Boolean
  Dim strRec As String
  
  '空きファイル番号を取得します
  dfn = FreeFile
  'ファイルをInputモードでOpen
  Open strFileName For Input As dfn
  
  Do Until EOF(dfn)
    '1レコード読み込み
    Line Input #dfn, strLine
    '物理レコードを論理レコードに追加
    strRec = strRec & strLine
    'レコードをフィールドに分割
    vntField = SplitCsv(strRec, ",", , , blnMulti)
    If blnMulti Then
      strRec = strRec & vbLf
    Else
      '指定シートに書き込み
      With wksWrite.Cells(lngRow, lngCol)
        .Offset.Resize(, UBound(vntField) + 1) = vntField
      End With
      lngRow = lngRow + 1
      strRec = ""
    End If
  Loop
  
  Close #dfn
  
End Sub

Private Function SplitCsv(ByVal strLine As String, _
            Optional strDelimiter As String = ",", _
            Optional strQuote As String = """", _
            Optional strRet As String = vbCrLf, _
            Optional blnMulti As Boolean) As Variant

'      strLine     :分割元と成る文字列
'      strDelimiter  :区切り文字
'      SplitCsv    :戻り値、切り出された文字配列

  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim i As Long
  Dim vntField As String
  Dim lngLength As Long
  
  i = 0
  lngStart = 1
  lngLength = Len(strLine)
  blnMulti = False
  Do
    ReDim Preserve vntData(i)
    If Mid$(strLine, lngStart, 1) <> strQuote Then
      lngDPos = InStr(lngStart, strLine, _
            strDelimiter, vbBinaryCompare)
      If lngDPos > 0 Then
        vntField = Mid$(strLine, lngStart, _
                  lngDPos - lngStart)
        lngStart = lngDPos + 1
      Else
        vntField = Mid$(strLine, lngStart)
        lngStart = lngLength + 1
      End If
    Else
      lngStart = lngStart + 1
      Do
        lngDPos = InStr(lngStart, strLine, _
                strQuote, vbBinaryCompare)
        If lngDPos > 0 Then
          vntField = vntField & Mid$(strLine, _
                lngStart, lngDPos - lngStart)
          lngStart = lngDPos + 1
          Select Case Mid$(strLine, lngStart, 1)
            Case ""
              Exit Do
            Case strDelimiter
              lngStart = lngStart + 1
              Exit Do
            Case strQuote
              lngStart = lngStart + 1
              vntField = vntField & strQuote
          End Select
        Else
          blnMulti = True
          vntField = Mid$(strLine, lngStart) & strRet
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = ""
    i = i + 1
  Loop Until lngLength <= lngStart
  
  SplitCsv = vntData()
  
End Function

Private Function GetReadFile(vntFileNames As Variant, _
          Optional strFilePath As String, _
          Optional blnMultiSel As Boolean = False) As Boolean

  Dim i As Long
  Dim strFilter As String
  
  'フィルタ文字列を作成
  For i = 1 To 4
    strFilter = strFilter & Choose(i, "CSV File (*.csv),*.csv,", _
              "Text File (*.txt),*.txt,", _
              "CSV and Text (*.csv; *.txt),*.csv;*.txt,", _
              "全て (*.*),*.*")
  Next i
  
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames, False
  End If
  
  'ファイルを開くダイアログ表示ホルダを表示
  vntFileNames _
    = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

【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

【8238】ありがとうございます
お礼  ちっくん  - 03/10/5(日) 22:42 -

引用なし
パスワード
   ちょっと忙しくて検証していませんが有難うございます。
これからもよろしくお願いします。

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