エクセルのマクロについて

質問

エクセル2003を使用しています。もしよかったら教えてください。
【例】
エクセルシートを2つ使うことを前提として、
Sheet1にはA1:F50の6列範囲セルに対して1～60の範囲内の数字が決められた背景色とフォント色に従い元々ランダムに入っております。
次に新たにSheet2を作り、そのE1:J50の6列範囲セルに値を他からコピーしてきた数字がランダムに入っています。
上記Sheet1セル範囲とSheet2セル範囲を比較して、それぞれのセル範囲内の数字がそれぞれ一致した場合、Sheet2のセル群をSheet1のセルの背景色とフォントカラーを同一に変更するマクロがわかりませんでした。
また1～60範囲外数値であれば処理しません。

調べても、数値入力した時点で他のセルの背景・フォント色を同一に変更する方法しか無かったので、For Eachを使い、試してみたのが下記のマクロです。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim v, c As Range

'//変更されたセル範囲・値をチェックして、関係なければ処理をしない
If Target.Count > 1 Then Exit Sub
If Intersect(Range("E1:J50"), Target) Is Nothing Then Exit Sub
v = Target.Value
If Not IsNumeric(v) Or v < 1 Or v > 60 Then Exit Sub

'//参照するシートの範囲について順にチェック
'//値が同じだったら、フォントカラーと背景色を同じにして終了
For Each c In Worksheets("sheet1").Range("A1:F50")
If c.Value = v Then
Target.Interior.ColorIndex = c.Interior.ColorIndex
Target.Font.ColorIndex = c.Font.ColorIndex
Exit For
End If
Next c
End Sub

これで実行するとSheet2に数値を新たに入力してうまくいきます。
ただ、Sheet2へ他からコピーしてきた数値のセル背景・フォント色を変更することができないです。

上記の作業を次から次へと新規で対応しなければならず、数値の入力に疲れてきております。

うまくいくマクロありますでしょうか？

回答No.3

Wendy02 · ベストアンサー

こんにちは。

>Sheet2へ他からコピーしてきた数値のセル背景・フォント色を変更することができないです。

別にうまくいかないということはないのですが、ただ、#2さんのご指摘のように、
If Target.Count > 1 Then Exit Sub
としているので、ひとつのセルしかコピー＆ペーストを認めていません。
その部分を直せばよいわけです。

それから、v は、Variant 型しかありませんね。そのままで良いです。
それと、試してみましたが、再帰はしていないので、EnableEvents =False はいらないけれども、動きが悪いので、Application.ScreenUpdating を入れてみました。

少し直しみました。
貼り付けするときは、その場所が外れていることもあるので、あくまでも、Range("E1:J50")の部分だけを対象にします。
Set rng = Intersect(Target, Range("E1:J50"))

'-------------------------------------------

Private Sub Worksheet_Change(ByVal Target As Range)
　　Dim v As Variant, c As Range, s As Range
　　Dim rng As Range

　　Set rng = Intersect(Target, Range("E1:J50"))
　　If rng Is Nothing Then Exit Sub
　　Application.ScreenUpdating = False
　　For Each c In rng.Cells
　　　　For Each s In Worksheets("Sheet1").Range("A1:F50")
　　　　v = c.Value
　　　　If Not IsNumeric(v) Or v < 1 Or v > 60 Then Exit For
　　　　　　'色を一旦戻す
　　　　　　c.Interior.ColorIndex = xlColorIndexNone
　　　　　　c.Font.ColorIndex = xlColorIndexAutomatic
　　　　　　If s.Value = v Then
　　　　　　　　c.Interior.ColorIndex = s.Interior.ColorIndex
　　　　　　　　c.Font.ColorIndex = s.Font.ColorIndex
　　　　　　　　Exit For
　　　　　　End If
　　　　Next s
　　Next c
　　Application.ScreenUpdating = True
　　Set rng = Nothing
End Sub

お礼

本当にありがとうございました。
無事解決いたしました。
なるほど「色を一旦戻す」作業も入るわけですね。
おっしゃられる通りApplication.ScreenUpdatingで動きも普通に動作
しています。

回答No.2

abe_onesel

おそらくSheet2に変化があった時に実行するマクロを使っているのだと思うので、そのつもりで回答します。

内容を見た感じでは、Sheet2の１つのセルの値が変化すると、そのセルとSheet1の値を比較して、同じであれば色を同じにするようになっており、
複数セルの値を比較しているようには作られていないですね。

でも、本来使いたいのは一気に全部のセルを比較したいということですよね？

下記を参考にしてみてください。
Sheet2のE1:J50に変化があった時に、全部のセルを調べて色まで変更するようにしてみました。

Private Sub Worksheet_Change(ByVal Target As Range)
'''Dim v, c As Range

'//変更されたセル範囲・値をチェックして、関係なければ処理をしない
'''If Target.Count > 1 Then Exit Sub
If Intersect(Range("E1:J50"), Target) Is Nothing Then Exit Sub
'''v = Target.Value
'''If Not IsNumeric(v) Or v < 1 Or v > 60 Then Exit Sub

'//参照するシートの範囲について順にチェック
'//値が同じだったら、フォントカラーと背景色を同じにして終了
'''For Each c In Worksheets("sheet1").Range("A1:F50")

Dim X As Integer, Y As Integer
Dim R1 As Range, R2 As Range

For X = 1 To 6
For Y = 1 To 50
Set R1 = Sheets("sheet1").Cells(Y, X)
If R1.Value >= 1 And R1.Value <= 60 Then
Set R2 = Sheets("sheet2").Cells(Y, X + 4)
If R1.Value = R2.Value Then
R2.Interior.ColorIndex = R1.Interior.ColorIndex
R2.Font.ColorIndex = R1.Font.ColorIndex
End If
End If
Next Y
Next X

''''If Target.Count > 1 And c.Value = v Then
''''Target.Interior.ColorIndex = c.Interior.ColorIndex
''''Target.Font.ColorIndex = c.Font.ColorIndex
''''Exit For
''''End If
''''Next c

End Sub

お礼

解決いたしました。
ありがとうございました。

補足

大変参考になりました。ありがとうございました。
複数のセルが一括で一度に色・フォント変換出来ました。

Sheet1のデータ参照範囲をA1:F50→B3:H9（7行7列）に変更して実行してみたら今度は変換できませんでした。実際はsheet1はB3:H9（7行7列）がデータ参照範囲になります。

現在abe様ご推薦頂きましたマクロプログラムで、
For Each c In Worksheets("sheet1").Range("B3:H9")的に
データ参照範囲を追加変更するにはどうしたらよろしいでしょうか？
ご指導いただきました、下記一部分マクロ、
For X = 1 To 6
For Y = 1 To 50
Set R1 = Sheets("sheet1").Cells(Y, X)
If R1.Value >= 1 And R1.Value <= 60 Then
Set R2 = Sheets("sheet2").Cells(Y, X + 4)
上記も部分的にうまく理解できず、何回も改良トライしましたが失敗しております。
よろしくお願いいたします。

回答No.1

rivoisu

そういう時はこのサブの先頭にブレークポイントを設定してそこからステップ実行してみましょう。
原因ではありませんが変数宣言がおかしいです。