色による並べ替え（Microsoft Excel）

Sub SortByColor()

On Error GoTo SortByColor_Err

Dim sRangeAddress As String     Dim sStartCell As String     Dim sEndCell As String     Dim rngSort As Range     Dim rng As Range

Application.ScreenUpdating = False

sStartCell = InputBox("Enter the cell address of the " & _       "top cell in the range to be sorted by color" & _       Chr(13) & "i.e.  'A1'", "Enter Cell Address")



If sStartCell > "" Then         sEndCell = Range(sStartCell).End(xlDown).Address         Range(sStartCell).EntireColumn.Insert         Set rngSort = Range(sStartCell, sEndCell)

For Each rng In rngSort             rng.Value = rng.Offset(0, 1).Interior.ColorIndex         Next         Range(sStartCell).Sort Key1:=Range(sStartCell), _           Order1:=xlAscending, Header:=xlNo, _           Orientation:=xlTopToBottom         Range(sStartCell).EntireColumn.Delete     End If

SortByColor_Exit:

Application.ScreenUpdating = True     Set rngSort = Nothing     Exit Sub

SortByColor_Err:

MsgBox Err.Number & ": " & Err.Description, _       vbOKOnly, "SortByColor"

Resume SortByColor_Exit End Sub