180

view

補足
そこまで、できてるのでしたら、あとは、goldswallow_stageさんの示したコードを多次元配列に応用するだけでソートできるかと思います。

Variant型の変数（今回は「範囲」という名前にしました）に対して、セル範囲をセットすると、（↓この行です）
範囲 = ws.Range("A4:D" & ws.Range("B" & Rows.Count).End(xlUp).Row)

範囲＝セルA4:Dα範囲（αは入力済みのセル数）となるわけですが、

この配列は2次元配列となり、範囲(1,1)=A4の値、範囲(1,2)=B4の値、範囲(1,3)=C4の値、範囲(1,4)=D4の値、範囲(2,1)=A5の値・・・・と一度にセットされます。
つまり、範囲(1～α,1)に日付けがセットされているのでそれをgoldswallow_stageさんの示したコードで並べ替え同時に、(1～α,2～4)にも同じようにgoldswallow_stageさんの示したコードで並べ替えた値をセットし直せばいいわけですね＾＾

goldswallow_stageさんの示したコードのアゴリズムは、私は思いつきませんでしたｗｗｗ
（VBA内でソートを完結するための私の考え付いたコードは、2つ多次元配列を用意して、Rank関数とCountIf関数を併用する方法です。勉強になりました。）

多次元配列の要素数は、
UBound(範囲, 1)で、1次元目の要素の上限αの数が求まります。
今回は使ってませんが、
UBound(範囲,2)を使いますと2次元目の要素の数「4」が帰ってくるはずです。

今回の「範囲」配列変数は先にも述べたように2次元配列ですので、3次元目の配列の上限数
UBound(範囲,3)とやるとエラーとなる具合です。


**********************************************

Private Sub UserForm_Initialize()

Me.StartUpPosition = 0
Me.Left = 856
Me.Top = 138

'タイトルを設定
Me.Caption = "入力フォーム"

'リストを設定
Dim ws As Worksheet, r As Range

Set ws = Worksheets("入出金帳簿")

Dim 範囲 As Variant
範囲 = ws.Range("A4:D" & ws.Range("B" & Rows.Count).End(xlUp).Row) '並べ替える範囲を変数に格納

Dim i As Long, j As Long, c As Long, tmp As Variant

i = LBound(範囲, 1)
Do While i < UBound(範囲, 1)
j = UBound(範囲, 1)
Do While j > i
If 範囲(j, 1) < 範囲(i, 1) Then
tmp = Array(範囲(j, 1), 範囲(j, 2), 範囲(j, 3), 範囲(j, 4))

For c = 1 To 4: 範囲(j, c) = 範囲(i, c): Next
For c = 0 To 3: 範囲(i, c + 1) = tmp(c): Next

End If
j = j - 1
Loop
i = i + 1
Loop


For c = 1 To UBound(範囲, 1)

With ListBox1

.ColumnWidths = .Width - 6 & ",0,0,0"

Select Case 範囲(c, 2)
Case "集金"
.AddItem Format(範囲(c, 1), "m月d日")
.List(.ListCount - 1, 1) = 範囲(c, 2)
.List(.ListCount - 1, 2) = 範囲(c, 3)
.List(.ListCount - 1, 3) = 範囲(c, 1)
Case "振込"
.AddItem Format(範囲(c, 1), "m月d日")
.List(.ListCount - 1, 1) = 範囲(c, 2)
.List(.ListCount - 1, 2) = 範囲(c, 4)
.List(.ListCount - 1, 3) = 範囲(c, 1)
End Select

End With

Next c

End Sub



*******************************




Private Sub UserForm_Initialize()
Dim Sh As Worksheet
Dim Se As Range
Dim Ac As Range
Set Sh = ActiveSheet '現在選択されているシートを保存
Set Se = Selection '現在選択されているセルを保存
Set Ac = ActiveCell '現在アクティブなセルを保存


Me.StartUpPosition = 0
Me.Left = 856
Me.Top = 138

'タイトルを設定
Me.Caption = "入力フォーム"

'リストを設定
Dim ws As Worksheet, r As Range

Set ws = Worksheets("入出金帳簿")

Dim 範囲 As Variant

範囲 = ws.Range("A4:D" & ws.Range("B" & Rows.Count).End(xlUp).Row) '並べ替える範囲を変数に格納
Sheets.Add After:=Sheets(Sheets.Count) '新しいシートを追加
Range("A4:D" & UBound(範囲, 1)) = 範囲 '新しいシートに並べ替え範囲を貼り付け
Range("A4:D" & UBound(範囲, 1)).Sort Key1:=Range("A4"), Order1:=xlAscending, Key2:=Range("B4"), Order2:=xlDescending '並べ替えの実行

For Each r In Range("B4", Range("B" & Rows.Count).End(xlUp))

With ListBox1

.ColumnWidths = .Width - 6 & ",0,0,0"

Select Case r.Value
Case "集金"
.AddItem Format(r.Offset(0, -1).Value, "m月d日")
.List(.ListCount - 1, 1) = r.Value
.List(.ListCount - 1, 2) = r.Offset(0, 1).Value
.List(.ListCount - 1, 3) = r.Offset(0, -1).Value
Case "振込"
.AddItem Format(r.Offset(0, -1).Value, "m月d日")
.List(.ListCount - 1, 1) = r.Value
.List(.ListCount - 1, 2) = r.Offset(0, 2).Value
.List(.ListCount - 1, 3) = r.Offset(0, -1).Value
End Select

End With

Next r

Application.DisplayAlerts = False
ActiveSheet.Delete '新しく作ったワークシートを削除する
Application.DisplayAlerts = True

Sh.Select: Se.Select: Ac.Activate '前の状態に復帰

End Sub