Excel VBAでセルの整列

質問

Excel VBAでセルの整列

現在、VBAを勉強中の者です。

最近、勉強を始めたばかりですが、この前何とかVBAを用いてセルの塗り潰しが出来る様になりました。
そこで、今度は色が塗り潰されたセルを添付した画像のように整列したいと考えていますが、どんな風にすれば良いのか見当がつきません。

誰か、教えてください。

やりたい事は、A列に結合されているセルがいくつか存在していて、B列を挟んでC列にA列に関連する文字が入力されています。
そして、C列には予めセルが塗り潰されている箇所がありますが、今回、C列において塗り潰されているセルのみを、結合されているセルの最終行に移動させたいのです。

回答No.1

kybo · ベストアンサー

例えば、A1：B9に表があるとして。

Sub macro()
Dim C As Range
For Each C In Range("B2:B9")
If C.Interior.ColorIndex <> xlColorIndexNone Then
C.Cut
Range("B" & C.Offset(, -1).MergeArea.Row + C.Offset(, -1).MergeArea.Rows.Count).Insert Shift:=xlDown
End If
Next C
End Sub

回答No.2

Wendy02

どうも、位置がはっきり決まっていないような気がしますし、途中で変えましたと言われるもの嫌なので、
　*左上隅　ここの場所で、設定してください。現在は色はひとつの設定しかありません。

'//
Sub ColorSortPrg()
　Dim LastRow As Long
　Dim i As Long, j As Long, k As Long
　Dim StRng As Range, st As Long, cl As Long
　Set StRng = Range("A1") '*左上隅
　st = StRng.Row + 1
　cl = StRng.Column
　LastRow = Cells(Rows.Count, StRng.Column).End(xlUp).Row
　Application.ScreenUpdating = False
　For j = st To LastRow
　　k = Cells(j, cl).MergeArea.Rows.Count
　　For i = 1 To k
　　　With Cells(j, cl)
　　　　If .Cells(i, 2).Interior.ColorIndex <> xlColorIndexNone Then
　　　　　.Cells(i, 3).Value = 2
　　　　Else
　　　　　.Cells(i, 3).Value = 1
　　　　End If
　　　End With
　　Next i
　　sColorSort Cells(j, cl).MergeArea.Offset(, 1).Resize(k, 2)
　　Cells(j, cl).MergeArea.Offset(, 2).Resize(k, 1).ClearContents
　　j = Cells(j, cl).Row + Cells(j, cl).MergeArea.Rows.Count - 1
　Next
　Application.ScreenUpdating = True
End Sub
Private Sub sColorSort(rng As Range)
　rng.Sort Key1:=rng.Cells(1, 2), _
　　　　　 Order1:=xlAscending, _
　　　　　 Header:=xlNo
End Sub