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
      'ファイルから1行読み込み
      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
      '配列からファイルに1行書き込み
      .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 質問
【34613】Re:メモリ上のデータの整列について MARBIN 06/2/8(水) 10:17 発言
【34633】Re:メモリ上のデータの整列について VBAビギナー 06/2/8(水) 16:37 質問
【34811】Re:メモリ上のデータの整列について だるま 06/2/13(月) 15:23 回答
【34638】Re:メモリ上のデータの整列について ichinose 06/2/8(水) 18:42 発言
【34776】Re:メモリ上のデータの整列について Hirofumi 06/2/12(日) 11:12 回答

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