|
こんにちは
右側エリアだけ並べ替えるのかと思ってました。
Sub test4()
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)
Call test_sort(Intersect(t, .SpecialCells( _
xlCellTypeConstants).EntireRow), "A1", xlNo, xlAscending)
Call test_sort(Intersect(t, .SpecialCells( _
xlCellTypeBlanks).EntireRow), "A1", xlNo, xlAscending)
.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
これでどうでしょうか?
|
|