エクセルのマクロ（黄色付け）

前へ 次へ
このQ&Aのポイント
  • 派遣切り後、事務職の就職がようやく見つかりました。仕事の効率を上げるためにマクロを作成したいです。
  • 赤色付け機能ではSheet1のA列の数字を検索し、Sheet2で一致したセルを赤くします。
  • 黄色付け機能ではSheet1の数字を検索し、Sheet2で一致しない数字を黄色に変えます。
回答を見る
  • ベストアンサー

エクセルのマクロ（黄色付け）

派遣切り後、事務職の就職がようやく見つかりました。 仕事の効率を少しでも上げて、より多くの業務処理をしたいので下記のマクロを作成したいと考えています。 １ヶ月前に書籍を購入して独自でできるか試したのですがダイレクトな情報が見つからず、基礎の部分だけはできたところです。 恐縮なのですがもし、できる方がいましたらぜひ教えて頂けませんでしょうか【黄色付け機能の所を】。 赤色付け機能（既に有り）： 下記のようにSheet1のA列の数字を１つずつ検索して、sheet2にその数字があれば、sheet2のそのセル赤くする。 Sub 赤色付け() Set WS1 = Worksheets("Sheet1") Set WS2 = Worksheets("Sheet2") Dim RowPos As Integer Dim i As Integer For RowPos = 1 To 200 If WorksheetFunction.CountIf(Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), WS1.Cells(RowPos, 1)) > 0 Then i = WorksheetFunction.Match(WS1.Cells(RowPos, 1), Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), 0) WS2.Cells(i, 1).Interior.ColorIndex = 3 End If Next End Sub 【黄色付け機能：】 sheet1羅列を検索してsheet2に無い場合、逆にsheet1のその数字（検索してなかった数字）を黄色にもする　ということは可能でしょうか。 下の場合、sheet1の123456と789123と456789が黄色になります。 そして、sheet2の123456と789123と456789以外が赤色になります。 ●sheet1のA列に下記のような数字が羅列(200行程)しています。 238062 238075 238096 238210 91518 238230 123456 789123 456789 ●sheet2のA列に下記のような数字が羅列しています。 91518 238062 238075 238096 238210 238230

質問者が選んだベストアンサー

  • ベストアンサー
  • chuchuo
  • ベストアンサー率45% (99/217)
回答No.1

Set WS1 = Worksheets("Sheet1") Set WS2 = Worksheets("Sheet2") Dim RowPos As Integer Dim i As Integer For RowPos = 1 To 200 If WorksheetFunction.CountIf(Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), WS1.Cells(RowPos, 1)) > 0 Then i = WorksheetFunction.Match(WS1.Cells(RowPos, 1), Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), 0) WS2.Cells(i, 1).Interior.ColorIndex = 3 ELSE　'追加 WS1.Cells(RowPos, 1).Interior.ColorIndex = 6 '追加 End If Next 一例です。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. その他MS Office製品

関連するQ&A

  • 全部黄色になってしまいます

    下記のマクロを作成しました。 1.Sheet1のA列の数字を１つずつ検索して、sheet2にその数字があれば、sheet2のそのセル赤くする。 全部あればすべてのセルが赤くなり、無いところがあれば白いままというマクロ 2.sheet1羅列を検索してsheet2に無い場合、逆にsheet1のその数字（検索してなかった数字）を黄色にする。 困っていることは、何も数字の無いところが全部黄色になってしまいます。 sheet1の空白のところは処理せずにそのまま白くあって欲しいのですがどのようにすればいいでしょうか？ ●sheet1のA列に下記のような数字が羅列(200行程)しています。 238062 238075 238096 238210 91518 238230 123456 789123 456789 ●sheet2のA列に下記のような数字が羅列しています。 91518 238062 238075 238096 238210 Sub 赤色付け() Set WS1 = Worksheets("Sheet1") Set WS2 = Worksheets("Sheet2") Dim RowPos As Integer Dim i As Integer For RowPos = 1 To 200 If WorksheetFunction.CountIf(Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), WS1.Cells(RowPos, 1)) > 0 Then i = WorksheetFunction.Match(WS1.Cells(RowPos, 1), Range(WS2.Cells(1, 1), WS2.Cells(200, 1)), 0) WS2.Cells(i, 1).Interior.ColorIndex = 3 ELSE WS1.Cells(RowPos, 1).Interior.ColorIndex = 6 End If Next End Sub

  • Excel 2007 マクロのIF構文について

    Excel 2007 マクロのIF構文について Sheet1からSheet2にIF構文を使用して、 必要な情報を転記するマクロです。 下記マクロで実現できているのですが、IF構文が多く もっと効率的なマクロがあるのではないかと考えています。 IF構文が2つありますが、1つにまとめるマクロがありましたら お教えください。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") '「Sheet1」シートを更新 Worksheets("Sheet1").Range("A1").ListObject.QueryTable.Refresh BackgroundQuery:=False '「Sheet1」シートから「Sheet2」シートに転記 For i = 2 To ws1.Cells(Rows.Count, 1).End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, 13).End(xlUp).Row '「Sheet1」シートのL列から「Sheet2」シートのS列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "S") = ws1.Cells(i, "L") End If '「Sheet1」シートのG列から「Sheet2」シートのQ列に転記 If ws2.Cells(j, "M") = ws1.Cells(i, "A") Then ws2.Cells(j, "Q") = ws1.Cells(i, "G") End If Next j Next i End Sub

  • エクセル：マクロの手直し

    お世話になります。 以前ここで教えてもらったマクロのシート名のつけ方をすこし手直ししたいのでアドバイスください。 以下のマクロは、１シート目を決まった行数分に分割し各シートに振り分けるものです。今のマクロではシート名は分割1、分割2…分割10…などなりますが、Worksheets(1) のシート名＋3桁の連番（001,002…010…）などとしたい。 Worksheets(1) のシート名が「総務課」の場合、総務課001,総務課002…総務課010…となるのが理想です。 このようにするためにはマクロをどのように修正すればよいか教えてください。 Sub シート分割() 　Dim WS1 As Worksheet 　Dim WS2 As Worksheet 　Dim i As Integer 　Dim Bunkatsu As Integer 　Set WS1 = Worksheets(1) 'コピー元のデータシート 　Set WS2 = WS1 　Bunkatsu = 1 　Application.ScreenUpdating = False 　For i = 7 To WS1.Cells(Rows.Count, 1).End(xlUp).Row Step 25 　　Set WS2 = Worksheets.Add(After:=WS2) 　　WS2.Name = "分割" & Bunkatsu 　　WS1.Rows("1:6").Copy WS2.Cells(1, 1) 　　WS1.Rows(i & ":" & i + 24).Copy WS2.Cells(7, 1) 　　Bunkatsu = Bunkatsu + 1 　Next 　Application.ScreenUpdating = True End Sub

  • Excel 2007 マクロ 別シートの情報を反映する方法

    Excel 2007 マクロ 別シートの情報を反映する方法 Sheet1とSheet2があります。 Sheet1のD列とSheet2のM列で同じ値があれば、 Sheet1のE列の値をSheet2のN列に反映するマクロを 作成しました。 下記が正しいと思っていたのですが、エラーメッセージは出ずに 値が反映されません。 マクロに問題点があればご指摘ください。 よろしくお願いいたします。 Sub Rist() Dim i, j As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") For i = 2 To ws1.Cells(Rows.Count, "D").End(xlUp).Row For j = 2 To ws2.Cells(Rows.Count, "M").End(xlUp).Row If ws2.Cells(j, "M") = ws1.Cells(i, "D") Then ws2.Cells(j, "N") = ws1.Cells(i, "E") End If Next j Next i End Sub

  • 下記エクセル列の並び替えマクロで、Callの際に変数が引き継がれません

    下記エクセル列の並び替えマクロで、Callの際に変数が引き継がれません。 何か方法はありませんでしょうか。 Sub 各学校() Dim i As Integer Worksheets("Sheet1").Activate For 元列 = 1 To 16 If Cells(1, i) = "学校" Then 新1列 = 元列 ElseIf Cells(1, i) = "住所" Then 新2列 = 元列 ElseIf Cells(1, i) = "電話" Then 新3列 = 元列 (略) End If Next Call 列の並び替え End Sub Sub 列の並び替え() Worksheets("Sheet2").Activate Cells.Clear Worksheets("Sheet1").Columns(新1列).Cut Worksheets("Sheet2").Columns("A").Insert Worksheets("Sheet1").Columns(新2列).Cut Worksheets("Sheet2").Columns("B").Insert Worksheets("Sheet1").Columns(新3列).Cut Worksheets("Sheet2").Columns("C").Insert （略） End Sub

  • エクセルののマクロについて教えてください

    Sub search() Dim i As Long, lastCol As Long, c As Range, str As String, wS As Worksheet Set wS = Worksheets("sheet2") wS.Cells.Clear str = Application.InputBox("検索内容を入力") Application.ScreenUpdating = False With Worksheets("sheet1") lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column .Columns(lastCol + 1).Insert For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row Set c = Range(.Cells(i, "A"), .Cells(i, lastCol)).Find(what:=str, LookIn:=xlValues, lookat:=xlWhole) If Not c Is Nothing Then .Cells(i, lastCol + 1) = 1 End If Next i If WorksheetFunction.CountIf(.Columns(lastCol + 1), 1) > 0 Then .Range("A1").AutoFilter field:=lastCol + 1, Criteria1:=1 .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy wS.Range("A1") wS.Columns.AutoFit wS.Columns(lastCol + 1).Delete wS.Activate .Columns(lastCol + 1).Delete .AutoFilterMode = False Else MsgBox "該当データなし" End If End With Application.ScreenUpdating = True End Sub エクセルで上のシステムをネットから持ってきました。 上から5行目のinputboxを"Sheet3"のA列からデータを持ってきてプルダウンで表示させたいのですがユーザーフォームでオブジェクトを組まないで表示させる方法を教えてください

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

    下記のようなプログラム組んでいます。 Sub 張付() Sheets("一覧表").Select Dim i As Long Dim ws1, ws2 As Worksheet Set ws1 = Worksheets("一覧表") Set ws2 = Worksheets("データー") For i = 5 To ws2.Cells(Rows.Count, 1).End(xlUp).Row ws1.Range("B5") = ws2.Cells(i, 2) 　　 'セルB5に氏名を入力 ws1.Range("C5") = ws2.Cells(i, 3) 　　 'セルC5に年齢を入力 ws1.Range("D5") = ws2.Cells(i, 4) 　　 'セルD5に電話番号を入力 この後、　ws1.Range("B5")のB5をB6にまた、C5はC6に改行してそれぞれデーターを移していきたい のですが、B5をB6に順次プラスする方法を教えて下さい。 よろしくお願いいたします。

  • エクセルで在庫表を作ろうとしています

    エクセルで在庫表を作ろうとしているのですが、躓いてしまって困っています。 TEST1 コードを手入力した後実行 TEST2 出庫数を入力した後実行 Option Explicit Option Base 1 Sub TEST1() 'コードを手入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL1 As String Dim vL2 As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r vL1 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 2, False) ws1.Cells(i, 1).Offset(, 1) = vL1 vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(i, 1), ws2.Range("A2:IV65536"), 3, False) ws1.Cells(i, 1).Offset(, 2) = vL2 Next i End Sub Sub TEST2() '出庫数を入力した後実行 Dim ws1 As Worksheet Dim ws2 As Worksheet Dim r&, i& Dim vL2 As Long Dim vL3 As String Dim syukko As Long Dim fnd As Range Dim zaiko As Long Set ws1 = Worksheets("Sheet1") Set ws2 = Worksheets("Sheet2") r = ws1.Cells(Rows.Count, 1).End(xlUp).Row For i = 2 To r If ws1.Cells(i, 4) > 0 Then syukko = ws1.Cells(4, 1).Offset(, 3).Value vL2 = Application.WorksheetFunction.VLookup(ws1.Cells(3, 2), ws2.Range("A2:IV65536"), 3, False) Set fnd = ws2.Range("A:A").Find(ws1.Cells(i, 1)) If fnd Is Nothing = False Then zaiko = vL2 - syukko fnd.Offset(, 2) = zaiko End If MsgBox ws1.Cells(i, 2) & "を" & syukko & "出庫します" & vbLf & "在庫は" & zaiko & "になります。" Else MsgBox "出庫数を入力して下さい" Exit Sub End If Next i ws1.Range("A2:D65536").ClearContents End Sub ここまでは作りました。 ですが、プロシージャの外では無効です と出てしまいます。 どうすればよいのでしょうか。 教えて下さい。 シート1のＢ2にコード・C3に名前・D2に現在個数・E2に出庫数を入力します。 実際にはB3からすうじを入力し、コードを入力すれば自然に名前と現在個数を シート2から探してくるようにしたいです。 シート2にはA列にコード、B列に名前、C列に現在庫数が載っている表があります(量が半端ではないです) 出来れば、1度出庫数を入れたら、次開いた時にシート2のC列にある現在個数が自然に減っていて、シート1にはフォームしか残らない状態にしたいです。 お願いします<m(__)m>

  • エクセル2003にて指定されたシートを複写するには？（２）

    エクセル2003にて指定されたシートを複写するには？（２） 同じ件で投稿してすみません。エクセル本を読んでも、ネットで探しても 丸2日進んでいないので、投稿させて頂きました。 以前、以下のURLで投稿したものです。 http://okwave.jp/qa/q5930740.html 【回答して頂いた内容】 Sub aaa() Dim Ws1 As Worksheet, Ws2 As Worksheet Set Ws1 = Worksheets("シート１") Set Ws2 = Worksheets("シート２") Dim Endrow As Long, r As Integer Endrow = Ws1.Cells(Rows.Count, 1).End(xlUp).Row For r = 1 To Endrow 　　　 Worksheets.Add After:=Worksheets(Worksheets.Count) 　　　ActiveSheet.Name = Ws1.Cells(r, 1).Value 　　　Cells(5, 1).Value = Ws1.Cells(r, 1).Value 　　　Cells(5, 2).Value = Ws1.Cells(r, 2).Value 　　　Cells(5, 3).Value = Ws1.Cells(r, 3).Value Next r Set Ws1 = Nothing Set Ws2 = Nothing End Sub と、ご回答を頂き、想定していた対応が出来ていますが、 問題が２つほどございます。 （１）ひとつは、シート名及びテキストをA列ではなく、J列から持ってくる必要がある。 （２）もうひとつは、1行目はタイトル行なので、2行目から開始する必要がある。 この2点を解消しようと、色々数字を入れて試したのですが、改善できないので、 どなたか、是非、アドバイス・ご享受を宜しくお願い申し上げます。

  • 置換のマクロ

    すみません、基礎的なことかもしれませんが、 調べてもわかりませんでした… 下記マクロで、今はwS1のA列に置換したい文字があった場合 置換をしてくれますが、 A列だけではなく、wS1のシート全体を指定する為にはどのように書き換えればいいでしょうか…？ Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A") の　wS1.Cells(i, "A")　を　Aではなく、シート全体の指定に変えたいのです。。 Sub 置換() Dim i As Long, k As Long, wS1 As Worksheet, wS2 As Worksheet Set wS1 = ActiveSheet Set wS2 = Worksheets("置換") Application.ScreenUpdating = False For i = 1 To wS1.Cells(Rows.Count, "A").End(xlUp).Row For k = 1 To wS2.Cells(Rows.Count, "A").End(xlUp).Row If InStr(wS1.Cells(i, "A"), wS2.Cells(k, "A")) > 0 Then wS1.Cells(i, "A") = Replace(wS1.Cells(i, "A"), wS2.Cells(k, "A"), wS2.Cells(k, "B")) End If Next k Next i Application.ScreenUpdating = True End Sub 過去の質問↓の回答にあったマクロから、少し変えて使わせていただいています。 http://okwave.jp/qa/q8293972.html

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する