こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

御願いします

Sheet4にある表から同じ値を検索するマクロです。
同じ値があったセルの背景を黄色に,ただし空白セルは空白の
ままにしたいのですが。
うまく動きません。
初めてマクロを立てました。
どうか解決にお力かして下さい。

*********************************************************
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim RetRange As Range
Dim lngYCnt As Long
Dim intXCnt As Integer

lngYCnt = Worksheets("Sheet4").UsedRange.Rows.Count
intXCnt = Worksheets("Sheet4").UsedRange.Columns.Count

For i = 1 To lngYCnt
For j = 1 To intXCnt

If Cells(i, j).Value = "" Then
Cells(i, j).Interior.ColorIndex = xlNone
Else
Set RetRange = Selection.Find(What:=Cells(i, j).Value, _
after:=ActiveCell, LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext)
If Not RetRange Is Nothing Then
If RetRange.Address <> Cells(i, j).Address Then
RetRange.Interior.ColorIndex = 36
Cells(i, j).Interior.ColorIndex = 36
End If



Next
Next

End If
ErrorHandler:
End Sub

投稿日時 - 2008-09-17 08:37:45

QNo.4334993

すぐに回答ほしいです

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(6)

ANo.6

デバッグ後のコードです
Private Sub Worksheet_Change(ByVal Target As Range)
  ' 検索先のセル範囲
  Dim FindRange As Range
  Set FindRange = Worksheets("Sheet4").UsedRange
  ' Targetが複数セル場合の対処
  Dim rr As Range
  For Each rr In Target
    ' 空白セルかチェック
    If rr.Value = "" Then
      ' セル内容を削除した場合の塗りつぶしのリセット
      rr.Interior.ColorIndex = xlNone
      FindRange.Interior.ColorIndex = xlNone
    Else
      Dim retRng As Range
      ' データの検索
      Set retRng = FindRange.Find(rr.Value, after:=FindRange(1, 1), _
        LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext)
      ' 同一箇所が見つかったかどうかのフラグ
      dim bChange as boolean
      If Not retRng Is Nothing Then
        ' 対象データが見つかった場合
        Dim ss As String
        ' Doループの脱出条件
        ss = retRng.Address(0, 0)
        Do
          'rr.Interior.ColorIndex = 36
          if ss <> retRng.Address(0,0) then
            retRng.Interior.ColorIndex = 36
            bChange = True
          End if
          ' 複数同じ記述があるかをチェック
          Set retRng = FindRange.FindNext(retRng)
        Loop While Not (retRng Is Nothing) And retRng.Address(0, 0) <> ss
      End If
      ' 変更したセル以外のセルが見つかった場合
      if bChange then rr.Interior.ColorIndex = 36
    End If
  Next
End Sub

NetFindはタイプミスです 正しくは FindNextです
最初に検索する場合の引数 Afterには Sheet4のデータ入力セルに左上を指示しています

投稿日時 - 2008-09-19 23:28:33

お礼

何度もありがとうございました。
数を重ねていくうちに少しずつわかってきました。

また,これからも力を借りることがあるかもしれませんが
宜しくお願いします。

投稿日時 - 2008-09-22 07:24:34

ANo.5

単純な変数のタイプミスです
      ss = retRng.Address(0,0)
としてください
retRangをretRngに変更です

エラーになったらそのエラーに対するヘルプなどを参照して
ご自身でも解決に向かうように努力しましょう
# 検証せずにコードを投稿した私も悪いのですが m(__)m

投稿日時 - 2008-09-17 22:51:19

お礼

ありがとうございます。
何とかヘルプ,インターネットを利用しながら進めています。

NetFindnの箇所がうまく進まず,NextFindに変更してみたのですが・・・
合っているでしょうか?
またセルを変更した後,同じ文字が存在していなくても
背景色が変更してしまします。
私自身でも解決できるよう進めます。
解決方法があれば教えてください!

投稿日時 - 2008-09-19 18:30:51

ANo.4

Setが抜けたようです

Set retRng = FindRange.Find( rr.value, after:=ActiveCell,

投稿日時 - 2008-09-17 14:04:31

お礼

早急な回答本当にありがとうございます。
' Doループの脱出条件
      ss = retRang.Address(0,0)
でオブジェクトが必要です。
という
エラーが出てしまいました。
解決方法を御願いします。

今日までに仕上げないといけず混乱していたのですが。
救われました。
ありがとうございます。

投稿日時 - 2008-09-17 15:34:12

ANo.3

初心者であれば質問のようなコードも、止むをえ無いともいえるが、
逆に初心者なら、条件付き書式の操作をして、マクロの記録を採れば、泥臭くなく、エクセルVBAらしいスマートなコードがわかる。
質問のような繰り返しロジックを使う前に、使わないで済む方法はないのか(結構このケースはある)、立ち止まって勉強することが、進歩につながると思う。
また条件付書式と使い方のエクセル固有の勉強も先立って必要であるが。他プログラム言語経験者などは、エクセルの機能の勉強より、コードの作成が優先しがちとおもうが。
同時に勉強してみては。
Sub Macro1()
Range("A1:C20").Select
Selection.FormatConditions.Delete
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF($A$1:$C$20,A1)>1"
Selection.FormatConditions(1).Interior.ColorIndex = 8
End Sub
A1:C29の可変化・変動化が課題としてあるが。

投稿日時 - 2008-09-17 11:47:49

ANo.2

ごめんなさい
for rr in Target

for each rr in Target
でした …

投稿日時 - 2008-09-17 11:14:53

お礼

ありがとうございます!
さっそく修正入れました。
' データの検索
    retRng = FindRange.Find( rr.value, after:=ActiveCell,
      LookIn:=xlFormulas, _
      LookAt:=xlPart, SearchOrder:=xlByRows, _
      SearchDirection:=xlNext)
部分でもエラーが出てしまったのですが。
お知恵を拝借したいです。
宜しくお願いします。

投稿日時 - 2008-09-17 13:28:21

ANo.1

ん?

シート4以外のシートでセルの内容が変更された場合
シート4の中に同一の記述があった場合
シート4と現在のシートのセルを黄色にしたい
といったことでしょうか?

この場合シート4の複数のセルに同じ記述があるのでしょうか?

' 検索先のセル範囲
dim FindRange as Range
Set FindRange = WorkSheets("Sheet4").UsedRange
' Targetが複数セル場合の対処
dim rr as range
for rr in Target
  ' 空白セルかチェック
  if rr.value ="" then
    rr.interior.colorIndex = xlNone
  else
    dim retRng as range
    ' データの検索
    retRng = FindRange.Find( rr.value, after:=ActiveCell,
      LookIn:=xlFormulas, _
      LookAt:=xlPart, SearchOrder:=xlByRows, _
      SearchDirection:=xlNext)
    if not retRng is nothing then
      ' 対象データが見つかった場合
      dim ss as String
      ' Doループの脱出条件
      ss = retRang.Address(0,0)
      do
        rr.interior.ColorIndex = 36
        retRng.Interior.ColorIndex = 36
        ' 複数同じ記述があるかをチェック
        set retRng = findRange.NetFind( rr )
      Loop while not( retRng is nothing) and retRng.Address(0,0) <> ss
    end if
  end if
next
といった具合でしょう …

投稿日時 - 2008-09-17 09:03:28

お礼

さっそくありがとうございます。
とっても心強い解答です。

>シート4の中に同一の記述があった場合
>シート4と現在のシートのセルを黄色にしたい
>といったことでしょうか?
>この場合シート4の複数のセルに同じ記述があるのでしょうか?

表があるシートがシート4です。
シート4のセルに変更があり,同じ値が存在しているセルの背景を
黄色にしたいのです。

A3に”木村”B6に”木村”D4に”田中”F5に”田中”とあった場合,
木村,田中のセルを黄色に。その他背景はなしです。
さっそく試したとこと
>for rr in Target
でエラーが出てしまいました。
助言宜しくお願いします。

投稿日時 - 2008-09-17 09:31:36

あなたにオススメの質問