- ベストアンサー
別の列のデータを検索してセルの色を変える
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列目のセルの色を薄い青にする。なければなしとアラートを出す」 ように改造したいのですが どうすればいいでしょうか? どうかお願いいたします。
- yuukiyuuki
- お礼率49% (528/1074)
- オフィス系ソフト
- 回答数6
- ありがとう数2
- みんなの回答 (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
その他の回答 (5)
- zap35
- ベストアンサー率44% (1383/3079)
#02です。 もしOffice2007をお使いの場合は、途中のFindメソッドを使っている行を以下に変更してください。(LookAt:=xlWhole を追加) Set trg = Columns(1).Find(What:=r.Value, LookIn:=xlValues, lookat:=xlWhole)
- imogasi
- ベストアンサー率27% (4737/17068)
>同じナンバーが複数あるときは最初だけ水色になるようです。 質問を一読して、複数該当が有るか、質問に書いてないのが気になった。初心者はこれが多い。複数有るなら、もうFind、FindNextが全セル初めから最後まで、その列データを総なめして、各セルの値を探すより無い。 該当が唯一と決まっているなら、1つなら、関数でおなじみの Sub test01() x = WorksheetFunction.Match("s", Range("A1:A10"), 0) MsgBox x End Sub のようなのも使えるが。 >どうすればいいでしょうか? 一部コードも書いているようだから、人に聞く前に、Find、FindNextのコードは、検索操作をして、マクロの記録を取り、改造することをやるべきだ。そうすれば疑問点は限られたものになる。 ーー 余り熟練者で無いのに、イベントに頼ってコードを書くべきでない。 本件でも元データが変更されたときなど、該当分を元に戻すなどを考えると苦労するよ。元のセルの値は教えてくれない。
- xls88
- ベストアンサー率56% (669/1189)
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
お礼
ありがとうございます。 同僚の仕事の管理が煩雑になっていまして していただいたご回答で助かると思います。 ポイントに差が付いてしまいましたが 20差し上げたかったです。 本当にありがとうございました。
- zap35
- ベストアンサー率44% (1383/3079)
複数のセルが同時に更新された場合はどうすればよいですか? 特にオートフィルで複数のセルに異なる値が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
- xls88
- ベストアンサー率56% (669/1189)
下記のようなことでどうでしょうか。 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
補足
さっそくありがとうございます。 見てみましたが 同じナンバーが複数あるときは最初だけ水色になるようです。 同じナンバーが複数ある時は最後というか一番下にだけ水色にするようにしたいです。 どうかお願いいたします。
関連するQ&A
- VBAでセルの色付を別の列にも追加するには
WINDOWS XP EXCELL 2003です。 いつもお世話になります。 現在下記の如く、 A列にマクロを設定しています。 ※A F列には下記の数式が入っています。 A2 =IF(B2="","",TEXT(B2,"mm")) F2 =IF(G2="","",TEXT(G2,"mm")) Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row >= 2 And Target.Address = Cells(Rows.Count, "C").End(xlUp).Address Then Target.Offset(0, -1).Value = Date End If Dim c As Integer If Target.Column <> 2 Then Exit Sub If Target.Value = "" Then c = 0 Else On Error GoTo line Select Case Month(Target.Value) Case 1: c = 46 Case 2: c = 4 Case 3: c = 39 Case 4: c = 6 Case 5: c = 7 Case 6: c = 8 Case 7: c = 43 Case 8: c = 3 Case 9: c = 44 Case 10: c = 24 Case 11: c = 40 Case 12: c = 17 End Select End If Target.Offset(0, -1).Interior.ColorIndex = c Target.Offset(0, -1).Font.ColorIndex = IIf(c = 1, 2, 0) Exit Sub line: Target.Offset(0, -1).Interior.ColorIndex = 0 Target.Offset(0, -1).Font.ColorIndex = 0 End Sub 上記のマクロに追加でF列にも同様にセルの色付けするにはどうすればいいか ご教授を御願いできないでしょうか。
- ベストアンサー
- その他MS Office製品
- エクセル VBA 変更→セルの色が変わる
http://okwave.jp/qa/q2601257.html ↑こちらの質問に近いのですが、 ・フォントではなくセルの背景色を変える ・A列からF列までのみ対象:G列以降は変更しても色が変わらない としたいのです。どのようにすれば良いのでしょうか。 VBAについては全く体系だって勉強したことがないので良く分かっていません。 見よう見まねで以下のようにしてみましたが、うまくいきませんでした。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column > 6 Then Exit Sub Target.Interior.Color = RGB(255, 0, 0) End Sub 3行目のTarget.~の所が黄色に示されてエラーがでます。 どのようにしたら上手くいくかご教示下さい。
- ベストアンサー
- オフィス系ソフト
- セルの値を変更した時に日付けが入るマクロ
エクセル2010を使っている者です。 19行以内、19列以内の範囲において変更があった場合は、変更のあった行の 20列目に日付けが入るようしたくて、以下のVBAを書いたつもりなんですが、 うまく動きません。 セルの値を変えたり、セルをダブルクリックして編集可能な状態にすると、 日付けは入るのですが、そのセルより右の19列目までのセルが全て 「41602」といった数字に変わってしまいます。 Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row = Target.Row > 19 Then Exit Sub If Target.Column > 19 Then Exit Sub Target.Offset(0, 1).Value = Date End Sub なお、上記のVBAは以下のサイトを見て作ったものです。 http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_event.html どなたか、どこがおかしいのかお教えください。
- ベストアンサー
- Excel(エクセル)
- VBAで別の列のセルにも色付け~2
WINDOWS XP EXCELL 2003です。 いつもお世話になります。 ご迷惑とは重々と承知しながら再度質問させていただきます。 1 御指導を賜りたいのは、 現在A列には月度を示す 01~12 が入力され月別にセルの背景色を塗りつぶしていますがこれをA列用のマクロを工夫してF列にも同様に適用したい。 例えば参照図で言うと A7 05 ピンク A8 05 ピンク A9 06 ライトブルー A10 07 草色 等のように ※ 参照図のF列のセルには背景色は適用していません。 2 参照図のそれぞれの設定は、 ※ 計画 と 生産はセル位置だけの違いで生産の方は割愛します。 D1 ユーザー定義 mm/dd D2 ユーザー定義 200000 D3 数値 A7 ユーザー定義 mm マクロ ボタン「計画入力」 Sub 計画入力() Dim GYOU '追加 GYOU = Range("C65536").End(xlUp).Row + 1 Cells(GYOU, 2).Value = Range("D1").Value Cells(GYOU, 3).Value = Range("D2").Value Cells(GYOU, 4).Value = Range("D3").Value End Sub ボタン「セルセット」 Sub 計画セル() Range("D1,D2,D3,D1").Select End Sub A列のセル塗りつぶし Private Sub Worksheet_Change(ByVal Target As Range) If Target.Row >= 8 And Target.Address = Cells(Rows.Count, "C").End(xlUp).Address Then Target.Offset(0, 0).Value = Date End If Dim c As Integer If Target.Column <> 2 Then Exit Sub If Target.Value = "" Then c = 0 Else On Error GoTo line Select Case Month(Target.Value) Case 1: c = 46 Case 2: c = 4 Case 3: c = 39 Case 4: c = 6 Case 5: c = 7 Case 6: c = 8 Case 7: c = 43 Case 8: c = 3 Case 9: c = 44 Case 10: c = 24 Case 11: c = 40 Case 12: c = 17 End Select End If Target.Offset(0, -1).Interior.ColorIndex = c Target.Offset(0, -1).Font.ColorIndex = IIf(c = 1, 2, 0) Exit Sub line: Target.Offset(0, -1).Interior.ColorIndex = 0 Target.Offset(0, -1).Font.ColorIndex = 0 End Sub 御指導よろしく御願いします。
- ベストアンサー
- その他MS Office製品
- メッセージボックスを表示させるエクセルマクロ
こんにちは。マクロ初心者です。 エクセル(Excel2003)でメッセージボックスを 表示させるマクロが思うようにいかず困っています。 B列に「○○会社」と入力されれば、 「取引先です。」 とメッセージボックスを表示させたいと思い、 次のとおりマクロを作成しました。 -------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 2 And Target Like "*会社" Then MsgBox "取引先です。" End If End Sub -------------------------------- しかし、コピーなどで複数のセルを貼り付ける(入力)行為をすると、 「実行エラー'13': 型が一致しません」と出てしまいます。 Worksheet_Change(ByVal Target As Range)を使っているので、 -------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) If Target.Count > 1 Then Exit Sub If Target.Column = 2 And Target Like "*会社" Then MsgBox "取引先です。" End If End Sub -------------------------------- と、「If Target.Count > 1 Then Exit Sub 」を入れれば、 メッセージは出なくなるのですが、 これだと、A列セルに、コピー&ペーストで複数セルを貼り付けた場合、 「○○会社」があっても、マクロが効いてきません。 複数セルの貼り付けにも対応させるには、 どのようにすればよろしいでしょうか? 基本的なところが理解できていないのだと自覚しておりますが、 どうかご教授願います。 長々とわかりづらい文章ですみません。よろしくお願いします。
- ベストアンサー
- オフィス系ソフト
- ある条件を加えてもマクロをちゃんと動かしたい
Private Sub Worksheet_Change(ByVal Target As Range) Dim i As Long If Target.Count <> 1 Then Exit Sub If Not IsNumeric(Target.Value) Then Exit Sub If Target.Value <> 1 Then Exit Sub If Intersect(Target, Range("W:W, AC:AC, AQ:AQ, AW:AW")) Is Nothing Then Exit Sub i = Target.Column - 6 ' Debug.Print Target.Address & " " & Target.End(xlToLeft).Column If i < 1 Then Exit Sub Target.Offset(0, i - Target.Column).Resize(1, 5).Copy Application.EnableEvents = False Target.PasteSpecial Paste:=xlPasteAll Application.CutCopyMode = False Application.EnableEvents = True Target.Select end sub 上のコードはW列、AC列、AQ列、AW列に1と入力すると、入力セルから みて6つ左から5つのデータがコピーされるマクロです。ここでAK列、BE列からみて8つ左から5つのデータをコピーする 条件を付加したいのですがうまくいきません。 If Intersect(Target, Range("AK:AK, BE:BE")) Is Nothing Then Exit Sub i = Target.Column - 8 ' ↑ このコードを追加する感じです。 この条件を付加しなければうまく動くのですが、付加して何とか動かしたいと考えています。 何か良い方法があればおしえていただけると幸いです。
- ベストアンサー
- オフィス系ソフト
- こんばんは、watabe007さん。
961awaawaです。 >シートモジュールに貼り付けてお試しください。 Private Sub Worksheet_Change(ByVal Target As Range) With Target If Intersect(.Cells, Range("L:M")) Is Nothing Then Exit Sub If .Row < 3 Or .Value = "" Then Exit Sub If Not IsNumeric(.Value) Then Exit Sub .Offset(, 3).Value = Cells(.Row, .Value).Value End With End Sub というソースを作って頂いたのですが、既に各sheetにprivate sub からなるソースが入ってましてコンパイルエラー(名前が適切ではありません Worksheet_Change)となります。他に方法等頂けましたらありがたいです。
- ベストアンサー
- Excel(エクセル)
- Excelで入力したセルの隣のセルに累計の表示を
無理難題を押し付けられて困っています。 画像のように、セルB3に入力し、その累計を隣のセルC3に表示させたいのです。 以下、B4~B6も同じです。 同様のことをD⇔E、F⇔G、H⇔I、J⇔K・・・・でも行いたいのです。 ここの質問欄を検索し、以下のVBAを見つけました Const inpColumn = "C" '入力する列名が『A』列の場合 Private Sub Worksheet_Change(ByVal Target As Excel.Range) With Target '単一セルに入力した場合 If .Count = 1 Then '入力する列名に入力した場合 If .Column = Range(inpColumn & "1").Column Then '入力が数値の場合 If IsNumeric(.Value) Then '隣の列『B列』の値に入力した値を加える '(Offsetの2番目の1が1つ右のB列を示す) .Offset(0, 1) = .Offset(0, 1) + .Value End If End If End If End With End Sub これを実行したところ、B⇔Cだけが実行され、他の列では駄目でした。 VBAに無知なもので、どこを直せばよいのか全く分かりません。 また、他の方法があるのかも分かりません。 説明不足かも知れませんが、よろしくお願いいたします。
- ベストアンサー
- ノートPC
- 「Worksheet_Change」で2つの操作を
お世話になります。 当方、エクセルの超初心者です。 仕事で、ある作業表の作成を任されたのですが、一部が思い通りに動作しません。 最初は「例1」のような記述によりエラーしました。 【例1】 Private Sub Worksheet_Change(ByVal Target As Range) (内容1) End Sub Private Sub Worksheet_Change(ByVal Target As Range) (内容2) End Sub その後、過去の回答にあった類似案件を参考に「例2」のように書き換えましたが、 実行されるのは1つ目のみで、2つ目の内容は無視され、困っております。 【例2】 Private Sub Worksheet_Change(ByVal Target As Range) (内容1) (内容2) End Sub ちなみに実データは以下の通りです。 Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Target.Count <> 1 Then Exit Sub If Intersect(Target, Range("k6:k55")) Is Nothing Then Exit Sub If Target.Value = "" Then Target.Value = "○" Else Target.Value = "" If Target.Count <> 1 Then Exit Sub If Target.Column <> 2 Then Exit Sub If Target.Row < 6 Or Target.Row > 45 Then Exit Sub Call ShowCalendarFromRange2(Target) End If End Sub 見様見真似で作ったため、恥ずかしながら基本が全く理解できていません。 恐らく簡単なミスだと思うのですが、自力では解決方法を探し出せませんでした。 何とか2つの内容が実行できないものでしょうか。 どうか、お知恵をお貸し下さい。
- 締切済み
- その他MS Office製品
- エクセル 加算
1つのセルに数字を入力すると加算されているマクロを探していたら 以下の回答がありました Dim memo Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address <> "$A$1" Then Exit Sub If Target.Value <> "**" And IsNumeric(Target.Value) = False Then Exit Sub Application.EnableEvents = False If Target.Value = "**" Then memo = 0 Else memo = memo + Target.Value End If Target.Value = memo Application.EnableEvents = True End Sub このマクロですがA1に入力した場合に適用しますが、このマクロをたとえばA1からC1の範囲で使用した1場合にどのようなマクロをすればよいかわかりません それか、このマクロではそのようなことができるのかもわかりませんので教えて頂けないでしょうか
- ベストアンサー
- Excel(エクセル)
お礼
ご親切にありがとうございます。 職場で使うものですので運用法など昨日打ち合わせをしました。 ソフトの方に合わせるそうですので使わせていただきます。 本当に深く感謝しております。