Private Sub Worksheet_Change(ByVal Target As Range)
If (Target.Column <> 1) And (Target.Column <> 5) Then Exit Sub
If Not IsNumeric(Target.Value) Then Exit Sub
Target.Offset(0, 1).Value = Now()
End Sub

上記のスクリプトで
「1列目にナンバーを記入すると2列目に、5列目にナンバーを記入すると6列目に時刻が自動的にセルに入る」ようになっています。

これに追加で
「5列目にナンバーが記入されると、そのナンバーと同じものを1列目から探し出して、1列目のセルの色を薄い青にする。なければなしとアラートを出す」
ように改造したいのですが
どうすればいいでしょうか?

どうかお願いいたします。

A 回答 (6件)

#02です。

レスポンスありませんね。
複数のセルを同時に更新したり、オートフィルで複数のセルに同時に異なる値をセットしてもそれなりに動くようにしてみました。
セルを空白にしたときの動作などを付け加えましたので多少行数が多くなっていますが、ご参考まで。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim psw1, psw2 As Boolean
Dim rngA, rng, r, trg As Range
 Set rngA = Intersect(Target, Columns(1))
 Set rng = Intersect(Target, Columns(5))
 If rng Is Nothing Then
  Set rng = rngA
  If rng Is Nothing Then Exit Sub
 Else
  If Not rngA Is Nothing Then
   Set rng = Application.Union(rngA, rng)
  End If
 End If
 On Error GoTo end0
 Application.EnableEvents = False
 Application.ScreenUpdating = False
 Columns(1).Interior.ColorIndex = xlNone
 For Each r In rng
  If r.Value = "" Then
   r.Offset(0, 1).ClearContents
  Else
   If IsNumeric(r.Value) Then
    r.Offset(0, 1).Value = Now
    If r.Column = 5 Then
     psw1 = True
     Set trg = Columns(1).Find(What:=r.Value, LookIn:=xlValues)
     If Not trg Is Nothing Then
      Set trg = Columns(1).FindPrevious(trg)
      trg.Interior.ColorIndex = 24
      psw2 = True
     End If
    End If
   End If
  End If
 Next r
 If (psw1 = True) And (psw2 = False) Then
  MsgBox "A列に更新数値セルと同じ値はありません"
 End If
end0:
 Application.EnableEvents = True
 Application.ScreenUpdating = True
End Sub

ご質問があれば回答しますが、どこが分からないか具体的に書いていただけると助かります。ただ「解説してください」はご勘弁をm(_ _)m
    • good
    • 0
この回答へのお礼

ご親切にありがとうございます。
職場で使うものですので運用法など昨日打ち合わせをしました。
ソフトの方に合わせるそうですので使わせていただきます。

本当に深く感謝しております。

お礼日時:2009/05/19 03:44

#02です。


もしOffice2007をお使いの場合は、途中のFindメソッドを使っている行を以下に変更してください。(LookAt:=xlWhole を追加)

Set trg = Columns(1).Find(What:=r.Value, LookIn:=xlValues, lookat:=xlWhole)
    • good
    • 0

>同じナンバーが複数あるときは最初だけ水色になるようです。


質問を一読して、複数該当が有るか、質問に書いてないのが気になった。初心者はこれが多い。複数有るなら、もうFind、FindNextが全セル初めから最後まで、その列データを総なめして、各セルの値を探すより無い。
該当が唯一と決まっているなら、1つなら、関数でおなじみの
Sub test01()
x = WorksheetFunction.Match("s", Range("A1:A10"), 0)
MsgBox x
End Sub
のようなのも使えるが。
>どうすればいいでしょうか?
一部コードも書いているようだから、人に聞く前に、Find、FindNextのコードは、検索操作をして、マクロの記録を取り、改造することをやるべきだ。そうすれば疑問点は限られたものになる。
ーー
余り熟練者で無いのに、イベントに頼ってコードを書くべきでない。
本件でも元データが変更されたときなど、該当分を元に戻すなどを考えると苦労するよ。元のセルの値は教えてくれない。
    • good
    • 0

  Dim erng As Range



      fstAddress = frng.Address
      Do
        frng.Interior.Pattern = xlNone
        Set frng = .FindNext(frng)
        If fstAddress <> frng.Address Then
          Set erng = frng
        End If
      Loop While fstAddress <> frng.Address
      erng.Interior.colorIndex = 33
    • good
    • 0
この回答へのお礼

ありがとうございます。
同僚の仕事の管理が煩雑になっていまして
していただいたご回答で助かると思います。

ポイントに差が付いてしまいましたが
20差し上げたかったです。

本当にありがとうございました。

お礼日時:2009/05/19 03:53

複数のセルが同時に更新された場合はどうすればよいですか?


特にオートフィルで複数のセルに異なる値が1回の操作で入力されたらどうなるのが正解なのでしょう??

深く考えると色々難しくなるので、とりあえず複数のセルが更新されたら処理をスキップするようにしてみました。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim cnt As Long
Dim trg As Range
 If Target.Cells.Count > 1 Then
  MsgBox "複数のセルが同時に更新されました"
 Else
  If IsNumeric(Target.Value) Then
   On Error GoTo end0
   Application.EnableEvents = False
   Select Case Target.Column
   Case Is = 1
    Target.Offset(0, 1).Value = Now()
   Case Is = 5
    Target.Offset(0, 1).Value = Now()
    cnt = WorksheetFunction.CountIf(Columns(1), Target.Value)
    If cnt > 0 Then
     Set trg = Columns(1).Find(What:=Target.Value, LookIn:=xlValues, lookat:=xlWhole)
     For idx = 1 To cnt
      If idx = cnt Then
       Columns(1).Interior.ColorIndex = xlNone
       trg.Interior.ColorIndex = 24
      End If
      Set trg = Columns(1).FindNext(trg)
     Next idx
    Else
     MsgBox "A列に同じ値はありません"
    End If
   End Select
  End If
 End If
end0:
 Application.EnableEvents = True
End Sub
    • good
    • 0

下記のようなことでどうでしょうか。



Private Sub Worksheet_Change(ByVal Target As Range)
  Dim frng As Range
  
  If (Target.Column <> 1) And (Target.Column <> 5) Then Exit Sub
  If Not IsNumeric(Target.Value) Then Exit Sub
  Target.Offset(0, 1).Value = Now()
  If Target.Column = 5 Then
    With Columns("A:A")
      Set frng = .Find(Target.Value, .Cells(.Count), xlValues)
    End With
    If frng Is Nothing Then
      MsgBox "Not Found!", vbExclamation
    Else
      frng.Interior.colorIndex = 33
    End If
  End If
End Sub

この回答への補足

さっそくありがとうございます。

見てみましたが
同じナンバーが複数あるときは最初だけ水色になるようです。
同じナンバーが複数ある時は最後というか一番下にだけ水色にするようにしたいです。

どうかお願いいたします。

補足日時:2009/05/17 20:49
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング

おすすめ情報