Excel VBA について質問です。

質問

Excel VBA について質問です。
sheet１に、数字が入力され背景色がついたセルがあります。
sheet２に背景色ごとに１列に並び替えをしたいのですが、どのようにしたらよいでしょうか？
まったくの初心者で、どうしたらよいのかわかりません。
よろしくお願いします。

１、sheet１の背景色は、指定されていないため何色か指定できない。
２、セルの範囲も都度違うため、指定できない。
３、sheet２には、色ごとに１列に並べるのみでよい。

上記の内容でご理解いただけるでしょうか？
よろしくお願いします。

回答No.2

merlionXX · ベストアンサー

yawara3さん、ANo1の merlionXXです。
「セルの範囲も都度違うため、指定できない。」ということは、たとえばシートの最後あたりにあったりして検索する範囲が広くなると、先ほどの回答ではとてつもなく時間がかかってしまいますね。
背景色を設定したセルにはすべて「数値」が直接入力されているのですよね？（もし数式で数値が表示されているならちょっと修正が必要になります。）
ならば数値の入ったセルだけを限定して検索すれば早くなります。
以下のように書き直して見ました。

Sub test02()
　　Dim ws(1 To 2) As Worksheet '変数宣言
　　Dim myC As Range, x As Range
　　Dim c As Integer, i As Integer
　　Dim myDic As Object

　　Set myDic = CreateObject("Scripting.Dictionary")
　　Set ws(1) = Worksheets("Sheet1") 'Sheet1がws(1)
　　Set ws(2) = Worksheets("Sheet2") 'Sheet2がws(2)

　　With ws(2)
　　　　.Cells.ClearContents 'ws(2)のデータ消去
　　　　.Cells.Interior.ColorIndex = xlNone 'ws(2)のセル背景色消去
　　　　For Each myC In ws(1).UsedRange.SpecialCells(xlCellTypeConstants, 1) 'ws(1)の数値入力各セルで
　　　　　　c = myC.Interior.ColorIndex 'セル背景色の色Index取得
　　　　　　If c <> xlNone Then '背景色があれば
　　　　　　　　If Not myDic.exists(c) Then '初めての色なら
　　　　　　　　　　myDic.Add c, "" '格納
　　　　　　　　　　Set x = .Cells(1, Columns.Count).End(xlToLeft)
　　　　　　　　　　Set x = IIf(x.Value <> "", x.Offset(, 1), x)
　　　　　　　　　　x.Value = c 'Index記録
　　　　　　　　　　myC.Copy x.Offset(1)　'ws(2)にセル転記
　　　　　　　　Else 'あれば
　　　　　　　　　　Set x = .Range("A1:BE1").Find(What:=c, LookAt:=xlWhole) 'Index番号検索
　　　　　　　　　　Set x = IIf(x.Offset(1).Value <> "", x.End(xlDown).Offset(1), x.Offset(1))
　　　　　　　　　　myC.Copy x 'ws(2)にセル転記
　　　　　　　　End If
　　　　　　End If
　　　　Next myC
　　　　.Range("A1", Range("A1").End(xlToRight)).ClearContents 'Index行削除
　　　　.Range("A2").CurrentRegion.Cut ws(2).Range("A2").Offset(-1) '1行繰り上げ
　　End With

End Sub

お礼

とても、とても助かりました。完璧です。ありがとうございます。
教えていただいた内容を理解できるようにしたいと思います。
ほんとに、ありがとうございました。

回答No.1

merlionXX

一案です。
セルの背景色のColorIndexは0～56ですからこれを利用します。
Sheet1の使用範囲のセルを一個づつ見て、セルに背景色があればSheet2のColorIndex+1行目に順に貼り付けます。
最後に、何も貼り付かなかった列を削除します。

Sub test01()
　　Dim ws(1 To 2) As Worksheet '変数宣言
　　Dim myC As Range
　　Dim c As Integer
　　Set ws(1) = Worksheets("Sheet1") 'Sheet1がws(1)
　　Set ws(2) = Worksheets("Sheet2") 'Sheet2がws(2)
　　ws(2).Cells.Clear 'ws(2)のデータ消去
　　For Each myC In ws(1).UsedRange 'ws(1)の使用範囲の各セルにつき
　　　　c = myC.Interior.ColorIndex 'セル背景色のIndex取得
　　　　If c <> xlNone Then '色があれば
　　　　　　myC.Copy ws(2).Cells(Rows.Count, c + 1).End(xlUp).Offset(1) 'ws(2)に転記
　　　　End If
　　Next myC
　　ws(2).Range("A2:BE2").SpecialCells(xlCellTypeBlanks).EntireColumn.Delete '不要行削除
End Sub

こんな感じかな。