Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

46923 / 76732

←次へ　｜　前へ→


	【34776】Re:メモリ上のﾃﾞｰﾀの整列について

Hirofumi - 06/2/12(日) 11:12 -


	引用なし

	パスワード

こんな事なのかな？
TextFileを配列に読み込んで、先頭の時刻で整列して、別なTextFileに出力します
この時、新しいファイルは、元と成るTextFileと同じフォルダに出力されます
また、新しいファイルは、ファイル名に"Sorted"付けた物と成ります

Option Explicit

Public Sub CSVSort()
　　
'　 CSVデータの整列
　　　　
　　Const clngForReading As Long = 1
　　Const clngForWriting As Long = 2
　　Const clngForAppending As Long = 8
　　
　　Dim i As Long
　　Dim strPath As String
　　Dim strReadFile As String
　　Dim strOutputFile As String
　　Dim strData() As String
　　Dim dblTime() As Double
　　Dim lngIndex() As Long
　　Dim strBuff As String
　　Dim objFso As Object
　　Dim objOpenFile As Object
　　Dim lngLineNum As Long
　　Dim strProm As String
　　Dim blnStatusBar As Boolean
　　
　　'FSOのオブジェクトを取得
　　Set objFso = CreateObject("Scripting.FileSystemObject")
　　
　　'ファイルのPashを指定
'　　strPath = "C:\Documents and Settings\デスクトップ"
　　strPath = ThisWorkbook.path & "\TestData"
　　
　　'読み込むファイルを指定
'　　strReadFile = strPath & "\" & "test.txt"
　　strReadFile = strPath & "\" & "VBATest864Data.txt"
　　
　　'出力ファイル名を作成
　　With objFso
　　　　strOutputFile = strPath & "\" & .GetBaseName(strReadFile) _
　　　　　　　　　　　　& "Sorted" & "." & .GetExtensionName(strReadFile)
　　End With
　　
　　'ステータスバーの設定
　　With Application
　　　　'StatusBarの状態を保存
　　　　blnStatusBar = .DisplayStatusBar
　　　　'StatusBarを表示
　　　　.DisplayStatusBar = True
　　End With
　　
　　'指定ファイルをAppendモードでOpen
　　Set objOpenFile = objFso.OpenTextFile(strReadFile, clngForAppending)
　　'全行数の取得
　　lngLineNum = objOpenFile.Line - 1
　　'ファイルをClose
　　objOpenFile.Close
　　
　　'各配列を確保
　　ReDim strData(1 To lngLineNum)
　　ReDim dblTime(1 To lngLineNum)
　　ReDim lngIndex(1 To lngLineNum)
　　
　　'指定ファイルを読み込みモードでOpen
　　Set objOpenFile = objFso.OpenTextFile(strReadFile, clngForReading)
　　
　　'指定ファイルを読み込み
　　With objOpenFile
　　　　'ファイルEndまで繰り返し
　　　　Do Until .AtEndOfStream
　　　　　　'ファイルから１行読み込み
　　　　　　strBuff = .ReadLine
　　　　　　'書き込み位置を更新
　　　　　　i = i + 1
　　　　　　'1行分のデータを配列に確保
　　　　　　strData(i) = strBuff
　　　　　　'時間データを別配列に確保
　　　　　　dblTime(i) = TimeValue(Split(strBuff, ",")(0))
　　　　　　'Indexを作成
　　　　　　lngIndex(i) = i
　　　　　　Application.StatusBar = "ファイルから配列に読み込み中　" _
　　　　　　　　　　　　　　　　　　& i & "/" & lngLineNum & "行を処理"
　　　　Loop
　　　　'ファイルをClose
　　　　.Close
　　End With
　　
　　'時間をKeyにデータを整列
　　Application.StatusBar = "配列を整列中"
　　ShellSort dblTime, lngIndex
　　
　　'出力ファイルを書き込みモードでOpen
　　Set objOpenFile = objFso.OpenTextFile(strOutputFile, clngForWriting, True)
　　
　　'データを出力ファイルに出力
　　With objOpenFile
　　　　'データEndまで繰り返し
　　　　For i = 1 To lngLineNum
　　　　　　'配列からファイルに１行書き込み
　　　　　　.WriteLine strData(lngIndex(i))
　　　　　　Application.StatusBar = "配列からファイルに書き込み中　" _
　　　　　　　　　　　　　　　　　　　　& i & "/" & lngLineNum & "行を処理"
　　　　Next i
　　　　'ファイルをClose
　　　　.Close
　　End With
　　
　　strProm = "処理が完了しました"
　　
Wayout:
　　
　　'ステータスバーを元に戻す
　　With Application
　　　　.StatusBar = False
　　　　.DisplayStatusBar = blnStatusBar
　　End With
　　
　　Set objOpenFile = Nothing
　　Set objFso = Nothing
　　
　　MsgBox strProm, vbInformation
　　
End Sub

Private Sub ShellSort(dblList() As Double, _
　　　　　　　　　　　　lngIndex() As Long)

　　Dim i As Long
　　Dim j As Long
　　Dim lngGap As Long
　　Dim lngTmp As Variant
　　Dim lngTop As Long
　　Dim lngEnd As Long
　　
　　lngTop = LBound(dblList, 1)
　　lngEnd = UBound(dblList, 1)
　　
　　lngGap = 1
　　Do While lngGap < (lngEnd - lngTop + 1) \ 3
　　　　lngGap = 3 * lngGap + 1
　　Loop
　　
　　Do Until lngGap = 0
　　　　For i = lngGap + lngTop To lngEnd
　　　　　　lngTmp = lngIndex(i)
　　　　　　For j = i To lngGap + lngTop Step -lngGap
　　　　　　　　If dblList(lngIndex(j - lngGap)) _
　　　　　　　　　　　　　　　　　　<= dblList(lngTmp) Then
　　　　　　　　　　Exit For
　　　　　　　　End If
　　　　　　　　lngIndex(j) = lngIndex(j - lngGap)
　　　　　　Next j
　　　　　　lngIndex(j) = lngTmp
　　　　Next i
　　　　lngGap = lngGap \ 3
　　Loop

End Sub

0 hits

▼

【34612】メモリ上のﾃﾞｰﾀの整列について VBAビギナー 06/2/8(水) 10:06