Excel VBA質問箱 IV

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

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


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

8173 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

▼

【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


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

VBAビギナー - 06/2/8(水) 10:06 -


	引用なし

	パスワード

txtﾌｧｲﾙに
8:00,起床
1:00,就寝
12:00,昼食
10:00,学習
となったものを一行分のﾃﾞｰﾀをTime()という配列にいれて
それをｴｸｾﾙを介さず
1:00,就寝
8:00,起床
10:00,学習
12:00,昼食
にするにはどのようにしたらできるのでしょうか？


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

MARBIN - 06/2/8(水) 10:17 -


	引用なし

	パスワード

↓が参考になるかもしれません。

[ワークシートのSortメソッドを使わずに並べ替えを行なう。]
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_800.html


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

VBAビギナー - 06/2/8(水) 16:37 -


	引用なし

	パスワード

Sub test()
　　Dim fs As Object, f As Object, path As String, a As Integer, sortData() As String
　　path = "C:\Documents and Settings\デスクトップ\test.txt"
　　On Error GoTo Err_Proc
　　　　Set fs = CreateObject("Scripting.FileSystemObject")
　　　　Set f = fs.OpenTextFile(path, 1)　　　 'ﾌｧｲﾙのｵｰﾌﾟﾝ
　　　　If f.AtEndOfLine = False Then　　　　　　'ﾌｧｲﾙが空であるかの判定
　　　　a = 0
　　　　Do While f.AtEndOfStream <> True
　　　　　　ReDim Preserve sortData(a) As String
　　　　　　sortData(a) = f.ReadLine
　　　　　　a = a + 1
　　　　Loop
　　　　End If
Exit Sub
Err_Proc:　　　　　 'エラー後処理
　　MsgBox Err.Description
　　Exit Sub
これで配列に一行分のﾃﾞｰﾀをいれています。
loop後で配列の時間部だけでソートを行してきれいにしたいのですが？


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

ichinose - 06/2/8(水) 18:42 -


	引用なし

	パスワード

こんばんは。
どうしてExcelのSortでは駄目なのですか？
ソートのアルゴリズムを習得することは良いことですが、
私はＶＢＡをはじめてからソートのコードを書いたことがありません。

ＡＤＯを使用して読み込み時にソートしてしまう方法です。

>txtﾌｧｲﾙに
>8:00,起床
>1:00,就寝
>12:00,昼食
>10:00,学習

↑このデータがマクロを含むブックと同じフォルダにあるとして
（sample.txtという名前を例にしました）

標準モジュールに
'===============================================================
Private cn As Object 'コネクションオブジェクト
'===============================================================
Function open_ado_text(path As String) As Long
'テキストファイルにＡＤＯで接続する
'Input: path---テキストファイルがあるフォルダ
　　On Error Resume Next
　　Set cn = CreateObject("adodb.connection")
　　
　　link_opt = "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
　　　　　　　　 "DBQ=" & path & ";" & "ReadOnly=0"

　　cn.Open link_opt
　　open_ado_excel = Err.Number
　　On Error GoTo 0
End Function
'=====================================================
Sub close_ado()
'ＡＤＯの切断
　　On Error Resume Next
　　cn.Close
　　On Error GoTo 0
End Sub
'=====================================================
Function exec_sql(sql_str, rs As Object) As Long
'レコードセットを取得するSQLを実行する
'input sql---実行するsql
'output rs---レコードセット
'　　　 exec_sql--0--ok　Other--NG
　　On Error Resume Next
　　Set rs = cn.Execute(sql_str)
　　exec_sql = Err.Number
　　If Err.Number <> 0 Then MsgBox Err.Description
　　On Error GoTo 0
End Function
'================================================================
Function mk_schema_ini(path As String, dat() As String) As Long
'Schema.Iniファイルの作成
　　On Error GoTo err_mk_schema_ini
　　Dim fno As Long
　　Dim didx As Long
　　mk_schema_ini = 0
　　fno = FreeFile()
　　Open path & "\schema.ini" For Output As #fno
　　For didx = LBound(dat()) To UBound(dat())
　　　 Print #fno, dat(didx)
　　　 Next
　　Close #fno
ret_mk_schema_ini:
　　On Error GoTo 0
　　Exit Function
err_mk_schema_ini:
　　MsgBox Err.Description
　　mk_schema_ini = Err.Number
　　Resume ret_mk_schema_ini
End Function
'==========================================================
Function del_schema_ini(path As String)
'schema.iniファイルの削除
　　On Error Resume Next
　　Kill path & "\schema.ini"
　　On Error GoTo 0
End Function

別の標準モジュールに
'===========================================================
Sub main()
　　Dim ret As Long
　　Dim dat(1 To 6) As String
　　Dim rs As object
　　Dim ans As Variant
　　dat(1) = "[sample.txt]"
'　　　　　　　　　　　↑ﾃｷｽﾄﾌｧｲﾙ名前を指定
　　dat(2) = "ColNameHeader = False"
　　dat(3) = "CharacterSet = oem"
　　dat(4) = "Format = CSVDelimited"
　　dat(5) = "Col1=f1 date"
　　dat(6) = "Col2=f2 char width 255"
　　Call mk_schema_ini(ThisWorkbook.path, dat())
　　ret = open_ado_text(ThisWorkbook.path)
　　If ret = 0 Then
　　　 ret = exec_sql("select * from sample.txt order by f1", rs)
'　　　　　　　　　　　　　　　　　　　　↑ﾃｷｽﾄﾌｧｲﾙ名前を指定
　　　 If ret = 0 Then
　　　　　ans = Application.Transpose(rs.GetRows)
　　　　　For idx = LBound(ans, 1) To UBound(ans, 1)
　　　　　　 MsgBox Format(ans(idx, 1), "h:mm") & "---" & ans(idx, 2)
　　　　　　 Next
　　　　　rs.Close
　　　 Else
　　　　　MsgBox Error(ret)
　　　　　End If
　　　 close_ado
　　　 End If
　　Call del_schema_ini(ThisWorkbook.path)
End Sub

としてmainを実行してみてください。
ソートのアルゴリズムの勉強も兼ねていたなら失礼です。


	【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


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

だるま

- 06/2/13(月) 15:23 -


	引用なし

	パスワード

▼VBAビギナーさん：
>Sub test()
>　　Dim fs As Object, f As Object, path As String, a As Integer, sortData() As String
>　　path = "C:\Documents and Settings\デスクトップ\test.txt"
>　　On Error GoTo Err_Proc
>　　　　Set fs = CreateObject("Scripting.FileSystemObject")
>　　　　Set f = fs.OpenTextFile(path, 1)　　　 'ﾌｧｲﾙのｵｰﾌﾟﾝ
>　　　　If f.AtEndOfLine = False Then　　　　　　'ﾌｧｲﾙが空であるかの判定
>　　　　a = 0
>　　　　Do While f.AtEndOfStream <> True
>　　　　　　ReDim Preserve sortData(a) As String
>　　　　　　sortData(a) = f.ReadLine
>　　　　　　a = a + 1
>　　　　Loop
>　　　　End If
>Exit Sub
>Err_Proc:　　　　　 'エラー後処理
>　　MsgBox Err.Description
>　　Exit Sub
>これで配列に一行分のﾃﾞｰﾀをいれています。
>loop後で配列の時間部だけでソートを行してきれいにしたいのですが？

こんにちは ^d^

ファイルの読み書きはご自身でお出来になるようですので、配列のソートの部分
だけです。

各データのカンマの左側（時刻）だけを取出し、その並べ替えインデックスを
得ます。
その並べ替えインデックスを使って、元の配列を並べ替えながら別の配列に入
れます。

Sub test2()
　　Dim sortData As Variant
　　sortData = Array("8:00,起床", "1:00,就寝", "12:00,昼食", "10:00,学習")
　　
　　'===== ここから =====
　　Dim Tim() As Date
　　Dim C As Integer
　　Dim i As Integer
　　Dim p As Integer
　　Dim T As String
　　Dim Ndx As Variant
　　Dim SortedData() As String
　　
　　'時刻を取出す
　　C = UBound(sortData)
　　ReDim Tim(0 To C)
　　For i = 0 To C
　　　　T = sortData(i)
　　　　p = InStr(T, ",")
　　　　Tim(i) = CDate(Left$(T, p - 1))
　　Next
　　
　　'並べ替えインデックスを得る
　　Ndx = MsCombSortI(Tim)
　　
　　'並べ替えて別配列に収納
　　ReDim SortedData(0 To C)
　　For i = 0 To C
　　　　SortedData(i) = sortData(Ndx(i))
　　　　Debug.Print SortedData(i)
　　Next
　　
End Sub

'安定化コムソート
Private Function MsCombSortI(Target As Variant) As Variant
　　'昇順インデックスを返す。
　　'配列引数Targetは１次元限定。
　　Dim Idx() As Long
　　Dim L As Long
　　Dim U As Long
　　Dim i As Long
　　Dim gap As Long
　　Dim Temp As Long
　　Dim F As Boolean
　　
　　L = LBound(Target)
　　U = UBound(Target)
　　
　　'インデックス初期設定
　　ReDim Idx(L To U)
　　For i = L To U
　　　　Idx(i) = i
　　Next
　　
　　gap = U - L
　　F = True
　　
　　'並べ替え
　　Do While gap > 1 Or F = True
　　　　gap = Int(gap / 1.3)
　　　　If gap = 9 Or gap = 10 Then
　　　　　　gap = 11
　　　　ElseIf gap < 1 Then
　　　　　　gap = 1
　　　　End If
　　　　F = False
　　　　For i = L To U - gap
　　　　　　If Target(Idx(i)) > Target(Idx(i + gap)) Then
　　　　　　　　Temp = Idx(i)
　　　　　　　　Idx(i) = Idx(i + gap)
　　　　　　　　Idx(i + gap) = Temp
　　　　　　　　F = True
　　　　　　ElseIf Target(Idx(i)) = Target(Idx(i + gap)) Then
　　　　　　　　If Idx(i) > Idx(i + gap) Then
　　　　　　　　　　Temp = Idx(i)
　　　　　　　　　　Idx(i) = Idx(i + gap)
　　　　　　　　　　Idx(i + gap) = Temp
　　　　　　　　　　F = True
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　Loop

　　MsCombSortI = Idx()
End Function


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

8173 / 13644 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free