155

view

scplourbtsさん

【追記】
もし、この再計算のイベント処理が不便だったら、Sheet2を開いたときをイベントとする処理もできます。
必要なら「再質問」してください。

仕事がハードなので、、すぐに対応できないかも…ですが。。

【補足に対する追記】********

>数値は起動中にも変更されるので、それに伴いSheet2のマクロ結果も自動更新される。
つまり、Sheet1のF列の数式が変更された時に処理するわけですか？
じゃあ、Worksheet_Calculateのイベントを使えばできます。
下記のコードを指定どおり張り付けると、数式が再計算された時に自動実行します。

Private Sub Worksheet_Calculate()
Dim j As Long, c As Range
Dim myVal As Double, r As Long
Application.ScreenUpdating = False
With Sheets("Sheet2")
.Range("A:G").ClearContents
.Range("A1:G1").Value = Range("A1:G1").Value
j = Cells(Rows.Count, 1).End(xlUp).Row
r = 1
For Each c In Range("A2:A" & j)
Select Case c.Interior.ThemeColor
Case xlThemeColorAccent6
myVal = 0.1
Case xlThemeColorAccent5
myVal = 0.2
Case xlThemeColorAccent4
myVal = 0.4
Case xlThemeColorAccent3
myVal = 0.5
Case Else
myVal = 0.3
End Select
If c.Offset(, 5) >= myVal Then
r = r + 1
.Cells(r, 1).Resize(, 7).Value = c.Resize(, 7).Value
End If
Next c
.Activate
End With
Application.ScreenUpdating = True
End Sub

********** <シートモジュール> ************
＜マクロの貼り付け方＞＞
上記のコードをコピーして、、
エクセルのSheet1のシートタブ内で右クリック→「コードの表示」でVBE画面を出して、、
広い画面のカーソルが「テカテカ」しているところにコードを貼り付けます。
もうこの画面はいらないので、、右上の「×」で元のシートに戻ります。

【最初の回答】
リクエストありがとう。
師走はかなり忙しくて、回答が遅れました。。

条件が複雑になり、抽出件数も大量になるようですから、関数ではやらない方が良いです。
マクロ案です。
おそらく今後、行数の変更や、パーセントを参照する範囲が変更される可能性があるので、、
最初に下図のようにSheet1のデータのパーセントを参照するためにA列を色分けしてください。
10%→オレンジ色
20%→水色
30%→塗りつぶしなし
40%→紫色
50%→緑色
＊それぞれの色は、濃くても薄くても良いです。

ですから、提示された条件であれば、、
1行から1000行目は原価率30%以上→「何も色を付けません」⇒塗りつぶしなし
1001行目は原価率20%以上→色パレットの右から2列目「水色」
1002行目は原価率40%以上→色パレットの右から3列目「紫色」
1003〜1010行目は原価率50%以上→色パレットの右から4列目「緑色」
1011〜1020行目は原価率10%以上→色パレットの右端の「オレンジ色」
1021〜1030行目は原価率30%以上→「何も色を付けません」⇒塗りつぶしなし

ココまで出来上がったら、下記のコードを指定どおり張り付けてからマクロを実行します。
マクロ処理は、
１．最初にSheet2のA～G列をクリアします。
２．Sheet2の1行目にSheet1のA1:G1をコピペします。
３．Sheet1のA2から下方に色を判断して、同行のパーセントをチェックして処理します。
＊処理時間は1秒もかかりません。

Sub Sample()
Dim j As Long, c As Range
Dim myVal As Double, r As Long
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
With Sheets("Sheet2")
.Range("A:G").ClearContents
.Range("A1:G1").Value = Range("A1:G1").Value
j = Cells(Rows.Count, 1).End(xlUp).Row
r = 1
For Each c In Range("A2:A" & j)
Select Case c.Interior.ThemeColor
Case xlThemeColorAccent6
myVal = 0.1
Case xlThemeColorAccent5
myVal = 0.2
Case xlThemeColorAccent4
myVal = 0.4
Case xlThemeColorAccent3
myVal = 0.5
Case Else
myVal = 0.3
End Select
If c.Offset(, 5) >= myVal Then
r = r + 1
.Cells(r, 1).Resize(, 7).Value = c.Resize(, 7).Value
End If
Next c
.Activate
End With
Application.ScreenUpdating = True
End Sub

********** <標準モジュール> ************
＜マクロの貼り付け方＞
上記のコードをコピーして、、
エクセルのワークシート上で「Alt」+「F11」でVBE画面を出して、、
上のメニュー→「挿入」→「標準モジュール」をクリックして、
広い画面のカーソルが「テカテカ」しているところにコードを貼り付けます。
もうこの画面はいらないので、、右上の「×」で元のシートに戻ります。

＜マクロの実行＞
「Alt」+「F8」を押すと、マクロのダイアログが出てきますので、、
「Sample」が選択された状態で「実行」を押下します。。