| |
>Excel初心者です。
>今大学の研究で3,000,000行×4列のテキストファイルを、50,000×4列に分けて横に60個並べて読み込もうとしているんですが、どうしたらいいかわかりません。
>
>助言お願いします。
>
>あと2002を使っています。
如何しても、やって見るなら
Csvで4列×3,000,000行で下記の様なデータ
11903.57 15449.86 .000 .647
11826.67 15412.91 .000 5.266
11764.66 15382.12 2.974 5.266
11705.12 15345.17 .000 5.266
なら、時間が掛かりますが何とか行けるかも？
Vista 2.3G メモリ2G Excel2007で約60秒ぐらいかな？
Option Explicit
Public Sub ReadCsvExt()
' 指定行数分出力版(データ抽出)
'出力行数のサイズを設定
Const clngOutputSize = 50000
Dim lngWrite As Long
Dim lngRow As Long
Dim lngColumn As Long
Dim lngColumns As Long
Dim rngResult As Range
Dim vntResult() As Variant
Dim vntFilename As Variant
Dim dfn As Integer
Dim strBuff As String
Dim strRec As String
Dim blnMulti As Boolean
Dim strPrompt As String
Dim sngTime1 As Single
Dim sngTime2 As Single
'結果用配列の列初期値を設定
lngColumns = 3
If Not GetReadFile(vntFilename, ThisWorkbook.Path) Then
strPrompt = "マクロがキャンセルされました"
GoTo Wayout
End If
sngTime2 = Timer
'結果出力位置の指定
Set rngResult = ActiveSheet.Range("A1")
'画面更新を停止
Application.ScreenUpdating = False
'空きファイルバファ番号を取得
dfn = FreeFile
'ファイルをInputモードでOpen
Open vntFilename For Input As dfn
ReDim vntResult(1 To clngOutputSize, lngColumns)
Do Until EOF(dfn)
'ファイルより、1行読み込み
Line Input #dfn, strBuff
'論理レコードに物理レコードを追加
strRec = strRec & strBuff
'出力用配列を作成
lngRow = lngRow + 1
SplitCsv strRec, vntResult, lngRow, lngColumns, vbCrLf, blnMulti
If blnMulti Then
lngRow = lngRow - 1
strRec = strRec & vbLf
Else
strRec = ""
'★抽出条件（抽出の場合以下のコメントアウトを活かす）
' If (Val(vntResult(lngRow, 0)) <= 12000 _
' Or 15000 <= Val(vntResult(lngRow, 0))) _
' Or (Val(vntResult(lngRow, 1)) <= 17000 _
' Or 19000 <= Val(vntResult(lngRow, 1))) Then
' lngRow = lngRow - 1
' End If
End If
If lngRow = clngOutputSize Then
'結果をシートに出力
rngResult.Offset(lngWrite, lngColumn).Resize(lngRow, _
lngColumns + 1).Value = vntResult
lngColumn = lngColumn + 4
lngRow = 0
End If
Loop
'ファイルを閉じる
Close #dfn
'文字列バファにデータが残っている場合、配列に出力
If lngRow > 0 Then
'結果をシートに出力
rngResult.Offset(lngWrite, lngColumn).Resize(lngRow, lngColumns + 1).Value = vntResult
End If
strPrompt = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngResult = Nothing
sngTime1 = Timer
MsgBox strPrompt & vbLf & (sngTime1 - sngTime2), vbInformation
End Sub
Private Sub SplitCsv(strLine As String, _
vntData() As Variant, _
lngRow As Long, _
lngColumns As Long, _
strRet As String, _
Optional blnMulti As Boolean)
Const strDelimiter As String = ","
Const strQuote As String = """"
Dim i As Long
Dim lngDPos As Long
Dim lngStart As Long
Dim lngEnd As Long
Dim strField As String
Dim lngRowMax As Long
Dim strTmp As String
lngRowMax = UBound(vntData, 1)
'配列の添え字の初期値
i = 0
'Delimiter探索の開始位置
lngStart = 1
'分割元の文字列の長さ
lngEnd = Len(strLine)
'複数行Flagを初期化
blnMulti = False
'探索開始位置が分割元の文字列の長さを超えるまで分割
Do
'もし、開始位置の文字がstrQuoteと違う場合
If Mid$(strLine, lngStart, 1) <> strQuote Then
'Delimiterの位置を取得
lngDPos = InStr(lngStart, strLine, strDelimiter, vbBinaryCompare)
'Delimiterがある場合
If lngDPos > 0 Then
'開始位置からDelimiterの前までを取得
strField = Mid$(strLine, lngStart, lngDPos - lngStart)
'開始位置をDelimiterの後ろに更新
lngStart = lngDPos + 1
Else
'開始位置以降を取得
strField = Mid$(strLine, lngStart)
'開始位置を分割元の文字列の長さを超える位置に
lngStart = lngEnd + 1
End If
'開始位置の文字がstrQuoteと同じ場合
Else
'開始位置をstrQuoteの後ろに設定
lngStart = lngStart + 1
Do
'strQuoteの位置を取得
lngDPos = InStr(lngStart, strLine, strQuote, vbBinaryCompare)
'strQuoteがある場合
If lngDPos > 0 Then
'取得済みの文字列にstrQuote以降の文字列を加算
strField = strField & Mid$(strLine, lngStart, lngDPos - lngStart)
'開始位置をstrQuote以降に更新
lngStart = lngDPos + 1
'分割元の文字列の開始位置から１文字取得し
strTmp = Mid$(strLine, lngStart, 1)
'Delimiterなら
If strTmp = strDelimiter Then
'開始位置を１つ進める
lngStart = lngStart + 1
'Doを抜ける
Exit Do
'空白の文字列なら
ElseIf strTmp = "" Then
'Doを抜ける
Exit Do
'strQuoteなら
ElseIf strTmp = strQuote Then
'開始位置を１つ進める
lngStart = lngStart + 1
'取得済みの文字列にstrQuoteを加算
strField = strField & strQuote
End If
'strQuoteが無い場合
Else
'複数行Flagを立てる
blnMulti = True
strField = Mid$(strLine, lngStart) & strRet
'開始位置を分割元の文字列の長さを超える位置に
lngStart = lngEnd + 1
'Doを抜ける
Exit Do
End If
Loop
End If
'配列を確保
If i > lngColumns Then
lngColumns = lngColumns + 1
ReDim Preserve vntData(1 To lngRowMax, lngColumns)
End If
'配列に取得文字列を代入
vntData(lngRow, i) = strField
'取得文字列を初期化
strField = ""
'配列の添え字を更新
i = i + 1
Loop Until lngEnd < lngStart
End Sub
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
|
|
Hirofumi
- 09/11/28(土) 20:23 -
