| |
▼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
|
|
だるま
- 06/2/13(月) 15:23 -
