Excel VBA質問箱 IV

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

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


72994 / 76738 ←次へ | 前へ→

【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

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

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