| |
こんにちは
提示されたテストデータで確認しているので動くはずです。
ただし、右側エリアの並び替えにはユーザーリストを使っていますので、Excelのバージョンによってはダメなのかも・・・
こちらは Excel2003です。
SpecialCells を使っているので、データが有るか無いかどちらかだけのときのエラーだけ
回避すればいいと思いますので「On Error Resume Next」で簡単に済ませちゃってます。
Sub test5()
Dim s As Range
Dim t As Range
Dim sh As Worksheet
Const c As Long = 7
Dim x As Long
Set sh = Worksheets("Sheet1")
Set s = sh.Range("A7", sh.Cells(Rows.Count, "A").End(xlUp))
Set t = s.Resize(, c)
With t.Columns(c)
.Formula = "=IF(B7<>0,B7,"""")"
.Value = .Value
Call test_sort(t, "G1", xlNo, xlDescending)
On Error Resume Next
Call test_sort(Intersect(t, .SpecialCells( _
xlCellTypeConstants).EntireRow), "A1", xlNo, xlAscending)
Call test_sort(Intersect(t, .SpecialCells( _
xlCellTypeBlanks).EntireRow), "A1", xlNo, xlAscending)
On Error GoTo 0
.ClearContents
End With
Application.AddCustomList ListArray:=s.Value
x = Application.CustomListCount
With s.Offset(, c).Resize(, 5)
.Select
.Sort Key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlNo, _
OrderCustom:=x + 1, MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin
End With
Application.DeleteCustomList ListNum:=x
End Sub
Sub test_sort(Target As Range, Key As String, Header As XlYesNoGuess, Order As XlSortOrder)
With Target
.Select
.Sort _
Key1:=.Range(Key), Order1:=Order, _
Header:=Header, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
SortMethod:=xlPinYin, _
DataOption1:=xlSortNormal
End With
End Sub
> End Subがついていてもそのまま続いて実行できるのですね。
> 勉強不足でEnd Subがあるとそこで実行が途切れるのだと思っていました。
知らない事は誰でも知らないので大した事ではないです。
是非、Ｆ8キ−でステップ実行してみて下さい。
確認出来たら「.Select」しているコードはコメントアウトしていいです。
|
|
ウッシ
- 12/10/22(月) 16:48 -
