塗潰されたセルと同じ色の数字同士を抽出して並べる

質問

いつもお世話になっております。
ご存じの方がお見えでしたらご回答をよろしくお願いします。抽出
【質問】
　添付図の様に５×５マスが４つあり、それが縦に３つあります。
　５×５マスの４つの中には、黄色、緑色、赤色、青色の４色のいずれかでセルが
　塗り潰されています。M列に4色それぞれの色があり、
　その右側に左側の５×５マスの４つの中で同じ色で塗潰されたセルの数字を
　左から右に昇順に並べる方法が知りたいです。
【注意事項】
　　・５×５マスが４つの中で、４色全ての塗り潰しがある訳ではありません。
　　　※最低、黄色のみという場合があります。
　　・５×５マスが４つの中で、塗り潰されるセルは毎回異なります。
　　・同じ色で同じ数字（重複数字）がでてきてもそのまま並べます。
　　・使用するエクセルは２０１６です。

以上、よろしくお願いします。

回答No.2

SI299792 · ベストアンサー

済みません。この通りに作るのが面倒で、適当に自分でデータを作りました。
その時、全ての色が使われているデータを作ってしまいました。
使われてない色があっても大丈夫なように直しました。

Option Explicit
'
Sub Macro1()
　　Dim Cell As Range
　　Dim ColorTbl As String
　　Dim ColorStr As String
　　Dim Row As Long
　　Dim Index As Integer
　　Dim Colu As Long
'
　　[N:XFD].ClearContents
　　Application.ScreenUpdating = False
'
　　For Each Cell In [M1:M4]
　　　　ColorTbl = ColorTbl & Chr(Cell.Interior.ColorIndex)
　　Next Cell
'
　　For Row = 1 To Cells(Rows.Count, "A").End(xlUp).Row Step 13
'
　　　　For Each Cell In Cells(Row, "A").Resize(11, 11)
　　　　　　ColorStr = Chr(Cell.Interior.ColorIndex)
　　　　　　Index = InStr(ColorTbl, ColorStr) - 1
'
　　　　　　If Index >= 0 Then
　　　　　　　　Colu = _
　　　　　　　　　　Cells(Row + Index, Columns.Count).End(xlToLeft).Column + 1
　　　　　　　　Colu = WorksheetFunction.Max(Colu, 14)
　　　　　　　　Cells(Row + Index, Colu) = Cell
　　　　　　End If
　　　　Next Cell
'
　　　　For Index = 0 To 3
　　　　　　Colu = Cells(Row + Index, Columns.Count).End(xlToLeft).Column
'
　　　　　　If Colu > 12 Then
　　　　　　　　Set Cell = Cells(Row + Index, "N").Resize(, Colu - 13)
'
　　　　　　　　With ActiveSheet.Sort
　　　　　　　　　　.SortFields.Clear
　　　　　　　　　　.SortFields.Add Cell
　　　　　　　　　　.SetRange Cell
　　　　　　　　　　.Orientation = xlLeftToRight
　　　　　　　　　　.Apply
　　　　　　　　End With
　　　　　　End If
　　Next Index, Row
End Sub

お礼

修正頂いたソースで実行確認問題なくできました。
ありがとうございました。

回答No.1

SI299792

Option Explicit
'
Sub Macro1()
　　Dim Cell As Range
　　Dim ColorTbl As String
　　Dim ColorStr As String
　　Dim Row As Long
　　Dim Index As Integer
　　Dim Colu As Long
'
　　[N:XFD].ClearContents
　　Application.ScreenUpdating = False
'
　　For Each Cell In [M1:M4]
　　　　ColorTbl = ColorTbl & Chr(Cell.Interior.ColorIndex)
　　Next Cell
'
　　For Row = 1 To Cells(Rows.Count, "A").End(xlUp).Row Step 13
'
　　　　For Each Cell In Cells(Row, "A").Resize(11, 11)
　　　　　　ColorStr = Chr(Cell.Interior.ColorIndex)
　　　　　　Index = InStr(ColorTbl, ColorStr) - 1
'
　　　　　　If Index >= 0 Then
　　　　　　　　Colu = _
　　　　　　　　　　Cells(Row + Index, Columns.Count).End(xlToLeft).Column + 1
　　　　　　　　Colu = WorksheetFunction.Max(Colu, 14)
　　　　　　　　Cells(Row + Index, Colu) = Cell
　　　　　　End If
　　　　Next Cell
'
　　　　For Index = 0 To 3
　　　　　　Colu = Cells(Row + Index, Columns.Count).End(xlToLeft).Column
　　　　　　Set Cell = Cells(Row + Index, "N").Resize(, Colu - 13)
'
　　　　　　With ActiveSheet.Sort
　　　　　　　　.SortFields.Clear
　　　　　　　　.SortFields.Add Cell
　　　　　　　　.SetRange Cell
　　　　　　　　.Orientation = xlLeftToRight
　　　　　　　　.Apply
　　　　　　End With
　　Next Index, Row
End Sub

補足

いつも大変お世話になっております。
回答を頂きましたソースを実行した所、
縦に３つある（５×５マスが４つの）うち、
一番目の５×５マスが４つの塗潰されたセルの数字は右に並んだ後、
「Microsoft Visual Basic for Applications 400」のエラーが出て止まります。
どこが悪いのでしょうか？