【エクセルＶＢＡ】特定のセルに色をつける

質問

・やりたいこと
ブック1,sheet3で色のついたセルを、ブック2の対応するセルに反映させるというものです。

ブック1
【図左上】sheet1 前年のデータ
【図右上】sheet2 今年のデータ
【図左下】sheet3 sheet1と2で差分のあったセルに色が付いている（セルには差分判断するための計算式有）

ブック2
【図右下】
ブック1のsheet3と色が対応するようにしたい。sheet3で色の付いているセル（差分のあったセル）
をブック2の対応するセルにも反映させる。
sheetの数は20～30ほど。フォーマットは同じで、データはそれぞれのシートで異なる。

マクロを組むかと思うのですが、どなたかよろしくお願いします。

回答No.6

tsubuyuki · ベストアンサー

すいません、一つ補足です。

> ブック1、sheet3のリスト上の氏名（佐藤、鈴木、田中・・・）は、
> ブック2でのsheet名では上から順に1,2,3・・・・と割り振られます。

とおっしゃっていますが、
今後の処理や閲覧の簡便性・応用性といった観点から、
シート名の付け方についてもう少し考慮されることをオススメします。

若しくはブック１の段階で名前の前に連番を付加するかどちらかですね。
要するに、ブック１の各行と、転記先のシート名に何らかの整合性を与えたほうが良いということです。

この程度の処理であればさほど問題になりませんが、
もう少し込み入った処理が必要になってくるとやはり若干戸惑います。

回答No.5

tsubuyuki

Sub sample()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

　　　　Set Sh1 = Workbooks("sample1.xls").Worksheets("sheet3")
　　　　For i = 2 To Sh1.Cells(Sh1.Rows.Count, 1).End(xlUp).Row
　　　　　　　　Set Sh2 = Workbooks("sample2.xls").Worksheets(i - 1)
　　　　　　　　For j = 2 To Sh1.Cells(i, Columns.Count).End(xlToLeft).Column
　　　　　　　　　　　　If Sh1.Cells(i, j) <> 0 Then
　　　　　　　　　　　　　　　　Sh2.Cells(j, 1).Interior.Color = vbRed
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　Sh2.Cells(j, 1).Interior.ColorIndex = xlNone
　　　　　　　　　　　　End If
　　　　　　　　Next j
　　　　Next i
End Sub

おそらく、コレでいけます。
データ開始行等、細かいフォーマットは私にはわかりませんので、
若干のずれが生じる可能性はありますが、残念ながらそこは与り知りません。

とは言え、上記の式を若干変えるだけで応用できると思います。
難しい処理文は一切無いと思っていますので、
どういう内容なのか読み取りつつ（勉強しつつ）、適宜応用くださいませ。
そうしないと、不具合が起きたときにご自身で手直しができませんから。

回答No.4

tsubuyuki

補足です。

当然のことですが、sheet3のリスト上の「氏名」が
ブック２のシート名と「完全に一致する」事が条件です。
その条件に合わないとエラーで止まりますのでご注意ください。

回答No.3

tsubuyuki

～補足を引用～
補足
図が見づらいかと思いますが、ブック1,sheet3のA列には行ごとに人物の名前が入っております。
一番上のＡ列を"佐藤"（A1が佐藤）だとすると、B1より右側以降のセルがブック2,"佐藤"シートの縦の列（A1から下）に対応しています。
～引用終了～

フォーマットは理解しました。
ところで、
「色をつける条件」は？
「色をつけたいセル」は？
その辺がやはり伝わってきません。

要するに・・

［ブック１．sheet3］が
　　　　Ａ　　　　Ｂ　　　　Ｃ　　　　Ｄ
１　　　氏名　　　項目１　　項目２　　項目３
２　　　佐藤　　　０　　　　１　　　　０
とある場合、差分が発生しているのは「Ｃ２」セル（佐藤の項目２）。
この場合、

［ブック２．"佐藤"シート］が
　　　　Ａ　　　　Ｂ
１　　　項目１
２　　　項目２
３　　　項目３
と、用意されており、色をつけたいのは「Ａ２」セル。
これが「氏名」ごとにシートを用意してある。

と言うことですか？

Sub sample()
Dim Sh1 As Worksheet
Dim Sh2 As Worksheet

　　　　Set Sh1 = Workbooks("sample1.xls").Worksheets("sheet3")

　　　　For i = 2 To Sh1.Cells(Sh1.Rows.Count, 1).End(xlUp).Row
　　　　　　　　Set Sh2 = Workbooks("sample2.xls").Worksheets(Sh1.Cells(i, 1).Value)
　　　　　　　　For j = 2 To Sh1.Cells(i, Columns.Count).End(xlToLeft).Column
　　　　　　　　　　　　If Sh1.Cells(i, j) <> 0 Then
　　　　　　　　　　　　　　　　Sh2.Cells(j, 1).Interior.Color = vbRed
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　　　Sh2.Cells(j, 1).Interior.ColorIndex = xlNone
　　　　　　　　　　　　End If
　　　　　　　　Next j
　　　　Next i
End Sub

補足

わかりづらくてすみません。推測していただいた通りです。（図も私が意図していたものとおなじです。）よってご質問への回答は省略されていただきます。
ただ1点、
”sheet3のリスト上の「氏名」がブック２のシート名と「完全に一致する」事”
こちらが違っていました。
ブック1、sheet3のリスト上の氏名（佐藤、鈴木、田中・・・）は、ブック2でのsheet名では上から順に1,2,3・・・・と割り振られます。
つまり、ブック1、sheet3で上から佐藤、鈴木、田中とあれば
ブック2のsheet名は佐藤が1,鈴木が2,田中が3・・・という風になります。

回答No.2

tsubuyuki

> ブック1　　sheet1と2で差分のあったセルに色が
> ブック2の対応するセルにも反映

この「対応セル」が例えば
　ブック１のsheet3のＡ１セルに色がついている
　→ブック２のsheet1のＡ１セルに色をつける
など、完全に番地が対応しているのであれば、
＃１さんの模範解答が参考になると思われます。

番地が異なるのであれば、
「対応するセルを指定する（探す）仕組み」
を組み込まないといけません。
（質問文中の図を見る限り、番地は一致していないように思えます。）
しかし残念ながら、質問文を何度読み返しても
「対応するセルがどこなのか」読み取れませんので、
このままではお望みの処理は（私には）書けません。

番地が異なる場合はその旨を「条件を添えて」補足ください。

補足

図が見づらいかと思いますが、ブック1,sheet3のA列には行ごとに人物の名前が入っております。
一番上のＡ列を"佐藤"（A1が佐藤）だとすると、B1より右側以降のセルがブック2,"佐藤"シートの縦の列（A1から下）に対応しています。

回答No.1

keithin

＞色のついたセル

具体的に「どうやって色を付けている」のですか。

●ケース１
こういう場合に一般的に使う「条件付き書式」を使っている場合

sub macro1()
　dim h as range
　dim w1 as worksheet
　dim w2 as worksheet

’具体的なブック名、シート名に応じて正しく修正する事
　set w1 = workbooks("Book1.xlsx").worksheets("Sheet3")
　set w2 = workbooks("Book2.xlsx").worksheets("UNKNOWN")

　for each h in w1.cells.specialcells(xlcelltypeformulas)

　’＞セルには差分判断するための計算式有
　’　具体的な数式の内容に応じてマクロを修正する事
　　if h <> 0 then
　　　w2.range(h.address).interior.color = vbred
　　end if
　next
end sub

●ケース２
ふつーにセルの塗色でセルを塗っている場合

sub macro2()
　dim h as range
　dim w1 as worksheet
　dim w2 as worksheet

’具体的なブック名、シート名に応じて正しく修正する事
　set w1 = workbooks("Book1.xlsx").worksheets("Sheet3")
　set w2 = workbooks("Book2.xlsx").worksheets("UNKNOWN")

　w1.range("A1:I21").copy
　w2.range("A1").pastespecial paste:=xlpasteformats
end sub