Excel VBA質問箱 IV

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

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


4834 / 13644 ツリー ←次へ | 前へ→

【54000】ExcelVBAの配列の開放について hiro 08/2/19(火) 21:31 質問[未読]
【54002】Re:ExcelVBAの配列の開放について neptune 08/2/19(火) 22:11 回答[未読]
【54010】Re:ExcelVBAの配列の開放について hiro 08/2/20(水) 0:51 質問[未読]
【54026】Re:ExcelVBAの配列の開放について neptune 08/2/20(水) 15:17 回答[未読]
【54035】Re:ExcelVBAの配列の開放について Hirofumi 08/2/20(水) 20:15 回答[未読]
【54038】Re:ExcelVBAの配列の開放について neptune 08/2/20(水) 22:17 発言[未読]
【54164】Re:ExcelVBAの配列の開放について hiro 08/2/27(水) 10:53 お礼[未読]

【54000】ExcelVBAの配列の開放について
質問  hiro  - 08/2/19(火) 21:31 -

引用なし
パスワード
   毎回お世話になっております。
また、ご質問させてください。

数十万レコードを処理する必要のあるVBAプログラムを作っています。
現在、私がやっている方法が以下のようなものです。
--------------------------------------------------------------------------
1.配列宣言
  dim array as Variant
2.CSVファイルをワークブックとして開く。
  Workbooks.OpenText filename:=csvName, DataType:=xlDelimited, _
  Comma:=True
3.CSVファイルの中身を全て配列に格納する。
  array = Workbooks("data01.csv").Worksheets(1).Range("A1:S65000")
4.配列を、目的のシートに範囲指定で貼り付ける。
  Workbooks("result.xls").Worksheets(x).Range("A1:S65000") = array
5.配列を初期化する。
  Erase array
2.〜5.を、csvファイルの数だけ繰り返す。
--------------------------------------------------------------------------

ちなみにcsvファイルは65000件毎に通し番号付きのファイル名で存在します。
csvファイルをシート別にひとつのxlsファイルに読み込んでから、本筋の処理を行う流れになっています。なので、csvファイルが10個あれば、それらをsheet1からsheet10にコピーするといった感じです。

このやり方で、120万件ほどのデータを処理しようとすると「メモリ不足です」の警告が出てしまいます。

配列の中身の貼り付けが終る毎に、Erase arrayで配列の初期化をしているのですが、Eraseでは配列の開放にはならないのでしょうか。

ご教授よろしくお願いします。

(何か足りない情報がございましたら、追記させていただきますのでご指摘ください。

【54002】Re:ExcelVBAの配列の開放について
回答  neptune  - 08/2/19(火) 22:11 -

引用なし
パスワード
   ▼hiro さん:
こんにちは

ファイルサイズにもよりますが、数10MB程度なら

>3.CSVファイルの中身を全て配列に格納する。
>  array = Workbooks("data01.csv").Worksheets(1).Range("A1:S65000")
の処理をやめて、CSVファイルから、直接、変数に取り込んで見たらどうですか?

【54010】Re:ExcelVBAの配列の開放について
質問  hiro  - 08/2/20(水) 0:51 -

引用なし
パスワード
   ▼neptune さん:
>▼hiro さん:
>こんにちは
>
>ファイルサイズにもよりますが、数10MB程度なら
>
>>3.CSVファイルの中身を全て配列に格納する。
>>  array = Workbooks("data01.csv").Worksheets(1).Range("A1:S65000")
>の処理をやめて、CSVファイルから、直接、変数に取り込んで見たらどうですか?

早速の返信ありがとうございます。

ファイルサイズは、1つのCSVで7〜8MBです。
CSVから直接変数に取り込むとはどういう処理をすればいいのでしょうか(汗

【54026】Re:ExcelVBAの配列の開放について
回答  neptune  - 08/2/20(水) 15:17 -

引用なし
パスワード
   ▼hiro さん:
こんにちは

>ファイルサイズは、1つのCSVで7〜8MBです。
>CSVから直接変数に取り込むとはどういう処理をすればいいのでしょうか(汗
愛想の悪い回答者に当たったのかな^ ^;;

いつもそうではありません。自分でやってない人にはそうですけどね。
と、いうことで、今日は特別大サービス。久しぶりに書きました。

ササッと書きましたので、ほとんど検証はしてません。そのおつもりで試してください。
一応動作確認はしてます。・・・程度です。
改造するなり、お好きにどうぞ。

Sub t2()
  Dim lineCount As Long
  Dim sLines() As String, sPath As String
  
  
  sPath = "E:\Data\Office\Excel\order.csv" 'パスは自分の環境に合わせる事
  lineCount = GetTextFileData(sPath, sLines)
  'ここでsLines()にすべての行が格納されているから、各要素を","で、更に分割して使用する
  'split関数使用すると楽チン
  '処理
End Sub
'/////////////////////////////////////////////////////////////
'textファイルを読み込み、行毎に配列変数に入れて返す
'-------------------------------------
'引数
'pfPath   :ファイルのフルパス
'pLines()  :文字列型の要素数無定義の配列変数(これに全データを入れて返す)
'-------------------------------------
'戻り値:成功時、0以上の行数。失敗時には-1を返す
'/////////////////////////////////////////////////////////////
Public Function GetTextFileData(pfPath As String, pLines() As String) As Long
  Dim lCount As Long
  Dim sBuf As String, sLines() As String
  Dim bytBuf() As Byte
  Dim fNum As Long, sCount As Long, i As Long
  
  lCount = 0
  On Error GoTo ErrHandler
  sCount = FileLen(pfPath)
  ReDim bytBuf(sCount)
  
  fNum = FreeFile()
  Open pfPath For Binary As #fNum
    Get #fNum, , bytBuf
  Close #fNum
  
  sBuf = StrConv(bytBuf, vbUnicode)
  pLines = Split(sBuf, vbCrLf)
  
  lCount = UBound(pLines)
  GetCSVFileData = lCount
  
  Exit Function
ErrHandler:
  MsgBox Err.Number & " : " & Err.Description
  Reset
  GetCSVFileData = -1
End Function

#意味を理解してから使ってくださいね。全部Helpに載っているコマンドですから。
15:15 編集:UPした関数がcsvでなく、textfile全部に使える事に気が付いて
   名前と説明を変更

【54035】Re:ExcelVBAの配列の開放について
回答  Hirofumi  - 08/2/20(水) 20:15 -

引用なし
パスワード
   一応、読み込みは、行処理(1行読み込み→1行分出力)なので、
コードが使うリソースは、少ないのですが?
なんせ、120万行は無理かも?(時間も掛かるし?)

Option Explicit

Public Sub DataRead()

  Dim i As Long
  Dim vntFileName As Variant
  Dim lngRow As Long
  Dim strPath As String
  Dim rngResult As Range
  Dim strProm As String
  Dim blnStatusBar As Boolean
  Dim objFso As Object

  '指定形式のファイル名を取得
  strPath = ThisWorkbook.Path
  If Not GetReadFile(vntFileName, strPath) Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If

  '◆出力先頭セル位置を設定(基準セル位置)
  Set rngResult = Workbooks.Add.Worksheets(1).Cells(1, "A")
'  Set rngResult = ActiveSheet.Cells(1, "A")
  
  With Application
    '現状のステータスバーの状態を保存
    blnStatusBar = .DisplayStatusBar
    'ステータスバーを表示
    .DisplayStatusBar = True
    '画面更新を停止
    .ScreenUpdating = False
  End With
  
  '警告をキャンセル
  Application.DisplayAlerts = False
  '追加したBookのシートを先頭を残し削除
  With rngResult.Parent.Parent
    For i = .Worksheets.Count To 2 Step -1
      .Worksheets(i).Delete
    Next i
  End With
  '警告を受け付ける
  Application.DisplayAlerts = False
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
  'シート名をファイル名に変更
  rngResult.Parent.Name = objFso.GetBaseName(vntFileName)
  
  'データの読み込み
  CSVRead vntFileName, rngResult, lngRow

  strProm = "処理が完了しました"

Wayout:

  Set objFso = Nothing
  Set rngResult = Nothing

  With Application
    '画面更新を再開
    .ScreenUpdating = True
    'ステータス バーの文字列を既定値に戻す
    .StatusBar = False
    'ステータス バーの設定を元に戻す
    .DisplayStatusBar = blnStatusBar
  End With

  MsgBox strProm, vbInformation

End Sub

Private Sub CSVRead(ByVal strFileName As String, _
          ByRef rngWrite As Range, _
          Optional ByRef lngRow As Long = 1, _
          Optional strDelim As String = ",")

  Dim i As Long
  Dim dfn As Integer
  Dim vntField As Variant
  Dim strBuff As String
  Dim blnMulti As Boolean
  Dim strRec As String
  Dim strSheetName As String
  Dim lngSheetsCount As Long
  Dim lngTop As Long
  
  'シート基準行位置を取得
  lngTop = rngWrite.Row
  '書き込みシート数
  lngSheetsCount = 1
  '現在のシート名を保存
  strSheetName = rngWrite.Parent.Name
  
  'ファイルをOpen
  dfn = FreeFile
  Open strFileName For Input As dfn

  Do Until EOF(dfn)
    '1行読み込み
    Line Input #dfn, strBuff
    '論理レコードに物理レコードを追加
    strRec = strRec & strBuff
    '論理レコードをフィールドに分割
    vntField = SplitCsv(strRec, strDelim, , , blnMulti)
    'フィールド内で改行が有る場合
    If Not blnMulti Then
      With rngWrite.Offset(lngRow)
        '出力範囲を文字列に設定
        .Offset(, 1).Resize(, 2).NumberFormat = "@"
        'データを出力
        .Resize(, UBound(vntField) + 1).Value = vntField
      End With
      '読み込み行数のカウントをとる
      i = i + 1
      Application.StatusBar = "読み込み中です...." & i & " レコード目"
      '出力行をインクリメント
      lngRow = lngRow + 1
      '書き込み行が、SheetEndを超えた場合
'      If lngRow > Rows.Count - lngTop Then
      If lngRow > 65000 Then
        With rngWrite
          '書き込み行を初期値に
          lngRow = 0
          'シートを追加
          Set rngWrite = .Parent.Parent.Worksheets. _
                  Add(after:=.Parent).Cells(.Row, .Column)
          '書き込みシート数
          lngSheetsCount = lngSheetsCount + 1
          'シート名を変更
          rngWrite.Parent.Name _
              = strSheetName & "(" & lngSheetsCount & ")"
          DoEvents
        End With
      End If
      strRec = ""
    Else
      'セル内改行として残す場合
      strRec = strRec & vbLf
    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

  Dim i As Long
  Dim lngDPos As Long
  Dim vntData() As Variant
  Dim lngStart As Long
  Dim vntField As Variant
  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)
        If lngDPos = lngLength Then
          ReDim Preserve vntData(i + 1)
        End If
        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)
          lngStart = lngLength + 1
          Exit Do
        End If
      Loop
    End If
    vntData(i) = vntField
    vntField = Empty
    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 strFilter As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt," _
        & "CSV and Text (*.csv; *.txt),*.csv;*.txt," _
        & "全て (*.*),*.*"
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  'もし、ディフォルトのファイル名が有る場合
  If vntFileNames <> "" Then
    SendKeys vntFileNames & "{TAB}", False
  End If
  '「ファイルを開く」ダイアログを表示
  vntFileNames _
      = Application.GetOpenFilename(strFilter, 1, , , blnMultiSel)
  If VarType(vntFileNames) = vbBoolean Then
    Exit Function
  End If
  
  GetReadFile = True
  
End Function

【54038】Re:ExcelVBAの配列の開放について
発言  neptune  - 08/2/20(水) 22:17 -

引用なし
パスワード
   こんにちは

今思ったんですが、120万件の作業を何でExcelでやってるんでしょうか?
はっきり言って、Excelの仕事ではないんじゃないでしょうか?

データにもよりますが、
CSVファイルとの事なので、データフォーマットも決まっているでしょうし
AccessなどのDBでやるか、DAO、ADO等のデータオブジェクトを使って、
処理してやるのが常道かと思います。

【54164】Re:ExcelVBAの配列の開放について
お礼  hiro  - 08/2/27(水) 10:53 -

引用なし
パスワード
   皆様

反応が非常に遅れてしまい申し訳ありません。

たしかにDBを使うという方が常套手段な気がします。
途中までExcelで作ってしまっていたため、ちょっと意地になっていた部分があり
、よしんばExcelで解決できるなら嬉しいなと思ったため、質問させていただきました。

アドバイス通り、開発環境の変更も検討してみます。

ありがとうございました。

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