Excel VBA質問箱 IV

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

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


73163 / 76732 ←次へ | 前へ→

【8052】Re:EXCEL97でテキストファイルをインポート時にメモリ不足
回答  Hirofumi E-MAIL  - 03/9/28(日) 15:01 -

引用なし
パスワード
   >これを回避する方法はあるのでしょうか...
>ご教授いただければ幸いです。

お役に立てなくて申し訳有りませんが、
私はBookとしてファイルを開く事を余りしないので、
直接、この件の解決策を提示できません

しかし、Bookとしてファイルを開くではなく、シートに直接読み込むなら以下の様な
コードで読めると思います

尚、このコードで読み込む場合、処理速度は期待しないで下さい
かなり遅いと思います
また、提示のコードは、アクティブシートのA列1行から書き込みます
書き込むシートを指定したい場合は、「書き込むシートの参照を設定」のActiveSheet
と成っている所を変更して下さい
また、「書き込む先頭行の初期値」と「書き込む先頭列の初期値」を変更すれば、
書き込む行列が変更できます
また、「vntFieldInfo = Array(」の所はOpenTextのFieldInfoと同じ設定方式にした積もりです

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

Option Explicit

Public Sub ReadCsv()

  Dim i As Long
  Dim vntFileName As Variant
  Dim vntFieldInfo As Variant
  Dim lngWriteRow As Long
  Dim lngWriteCol As Long
  Dim wksWrite As Worksheet
  Dim strPath As String
  
  '読み込むファイル名を取得
'  vntFileName = "CSVFILE"
'  strPath = "C:\work"
  vntFileName = "CSVTest1"
  strPath = ThisWorkbook.Path
  If Not GetReadFile(vntFileName, strPath) Then
    Exit Sub
  End If
  
'  Application.ScreenUpdating = False
  
  '書き込む先頭行の初期値
  lngWriteRow = 1
  '書き込む先頭列の初期値
  lngWriteCol = 1
  '書き込むシートの参照を設定
  Set wksWrite = ActiveSheet
  'FieldInfoを設定(OpenTextのFieldInfoと同じ?)
  vntFieldInfo = Array(Array(1, 2), Array(2, 2), Array(3, 2), _
            Array(16, 2), Array(17, 2), Array(18, 2), _
            Array(31, 2), Array(32, 2), Array(33, 2), _
            Array(46, 2), Array(47, 2), Array(48, 2), _
            Array(61, 2), Array(62, 2), Array(63, 2), _
            Array(76, 2), Array(77, 2), Array(78, 2), _
            Array(91, 2), Array(92, 2), Array(93, 2))
  'セルの書式を設定
  CellsFormat vntFileName, wksWrite, vntFieldInfo, _
                  lngWriteRow, lngWriteCol
  'シートに読み込み
  CSVReadSeq vntFileName, wksWrite, _
              lngWriteRow, lngWriteCol, True, ","
  
  Set wksWrite = Nothing
  
'  Application.ScreenUpdating = True
  
End Sub

Private Sub CSVReadSeq(ByVal strFileName As String, _
              ByVal wksWrite As Worksheet, _
              Optional ByRef lngRow As Long = 1, _
              Optional ByRef lngCol As Long = 1, _
              Optional ByRef blnHeader As Boolean = True, _
              Optional strDelim As String = ",")
  
  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
  
  'ファイルEndまで繰り返し
  Do Until EOF(dfn)
    '1レコード読み込む
    Line Input #dfn, strLine
    '論理レコードに物理レコードを加算
    strRec = strRec & strLine
    'レコードをフィールドに分割
    vntField = SplitLine(strRec, strDelim, , , blnMulti)
    'もし、1論理レコードが複数行に渡るなら
    If blnMulti Then
      '論理レコードにLfを付加
      strRec = strRec & vbLf
    Else
      If blnHeader Then
        '書き込みシートの指定行列を先頭として
        With wksWrite.Cells(lngRow, lngCol)
          '1レコード文のフィールを書き込み
          .Offset.Resize(, UBound(vntField) + 1) = vntField
        End With
        '書き込み行を更新
        lngRow = lngRow + 1
      End If
      strRec = ""
      blnHeader = True
    End If
  Loop
  
  Close #dfn
  
End Sub

Private Sub CellsFormat(ByVal strFileName As String, _
            ByVal wksWrite As Worksheet, _
            vntFieldAtt As Variant, _
            Optional ByVal lngRow As Long = 1, _
            Optional ByVal lngCol As Long = 1)

'  セルの書式設定
  
  Dim i As Long
  Dim dfn As Integer
  Dim lngRowCount As Long
  Dim strBuff As String
  Dim lngFormatCol As Long
  
  '空きファイル番号を取得
  dfn = FreeFile
  'ファイルをOpen
  Open strFileName For Input As dfn
  lngRowCount = 0
  Do Until EOF(dfn)
    Line Input #dfn, strBuff
    '行数を取得
    lngRowCount = lngRowCount + 1
  Loop
  'ファイルをClose
  Close #dfn
  
  '指定シートに就いて
  With wksWrite
    'FieldInfo全てに就いて繰り返し
    For i = 0 To UBound(vntFieldAtt, 1)
      '設定列を設定
      lngFormatCol = vntFieldAtt(i)(0) - 1
      '設定列の列の範囲を設定
      With .Cells(lngRow, lngCol + lngFormatCol)
        With Range(.Offset(), _
            .Offset(lngRow + lngRowCount - 2))
          'FieldInfoに従い書式を設定
          Select Case vntFieldAtt(i)(1)
            Case 1
              .NumberFormatLocal = "G/標準"
            Case 2
              .NumberFormatLocal = "@"
            Case 5
              .NumberFormatLocal = "yyyy/mm/dd"
          End Select
        End With
      End With
    Next i
  End With
  
End Sub

Private Function SplitLine(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  :区切り文字
'      SplitLine    :戻り値、切り出された文字配列

  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
  
  SplitLine = 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, 2, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function
0 hits

【8040】EXCEL97でテキストファイルをインポート時にメモリ不足 maeda 03/9/27(土) 14:41 質問
【8041】Re:EXCEL97でテキストファイルをインポート... Hirofumi 03/9/27(土) 16:55 発言
【8048】Re:EXCEL97でテキストファイルをインポート... Hirofumi 03/9/27(土) 22:21 回答
【8050】Re:EXCEL97でテキストファイルをインポート... maeda 03/9/28(日) 12:55 質問
【8052】Re:EXCEL97でテキストファイルをインポート... Hirofumi 03/9/28(日) 15:01 回答
【8054】Re:EXCEL97でテキストファイルをインポート... Hirofumi 03/9/28(日) 17:51 発言
【8055】Re:EXCEL97でテキストファイルをインポート... maeda 03/9/28(日) 21:13 お礼

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