データ検索&セルの背景色変更

このQ&Aのポイント
  • ユーザーフォームを利用してデータの検索結果を表示し、一部の情報を変更・上書きした後、セルの背景色を変更したいです。しかし、うまくできません。
  • シートAには商品データの表があり、シートBには廃棄商品のデータがあります。ユーザーフォームで登録番号を入力し検索すると、商品名・型番・状況が表示されます。
  • 検索結果を表示した後、状況を「在庫→廃棄」に変更して上書きし、そのセルの背景色をグレーに変更します。VB初級者のため、具体的な方法を教えてください。
回答を見る
  • ベストアンサー

データ検索&セルの背景色変更

ユーザーフォームを利用し、データの検索結果をユーザーフォームへ表示させ 一部の情報を変更・上書きした上で、その元データのセル背景色を変更したいのですが・・・どうもうまくできません。 ご助力お願いします。 ≪詳細≫ シートAは、データシートとしての表となっている。(商品データ) シートBは、廃棄商品のデータシート。(廃棄商品) 登録番号  商品名  型番  状況 11111   りんご  @@@  在庫 22222   みかん  !!!  在庫 33333   いちご  ###  在庫 検索ボタン   更新ボタン ※ユーザーフォームで、登録番号を入力+検索ボタンクリックすると、テキストボックス(ユーザーフォーム上)に登録番号・商品名・型番・状況が表示されるようになっている。 ※更新ボタンを押すと、廃棄商品シートへ入力される。 検索・表示後、状況を「在庫→廃棄」に変更し上書きする。 ※上書き・・・データのあった列・行に上書きする。 例 2列目にあるみかんの検索の場合、   「22222」を入力・検索し、ユーザーフォーム上に   「22222」「みかん」「!!!」「在庫」を表示させる。   「在庫」のみを「廃棄」に変更し、2列目の状況のみを変え   上書きする。 上書き後、この2列目の「22222」「みかん」「!!!」「廃棄」の セル背景色をグレーに変更する。 ちなみに上書き&背景色変更は、更新ボタンのワンクリックにて 動作させたいのですが、検索したデータを指定するコードがわかりません。 宜しくお願いします。 まだまだVBA初級者のため、具体的に教えて頂けると有難いです。 Private Sub cmd検索_Click() Dim SerchKey As String Dim SerchArea As Range Dim lRow As Long lRow = Sheets("商品データ").Cells(65536, "A").End(xlUp).Row + 1 SearchKey = Application.InputBox( _ Prompt:="登録番号を入力して下さい。", Type:=2) If SearchKey = "" Or SearchKey = "False" Then Exit Sub End If Set SearchArea = Sheets("商品データ").Range(Sheets("商品データ").Range("A1"), Sheets("商品データ").Range("A1").End(xlDown)) Set FoundCell = SearchArea.Find( _ What:=SearchKey, _ SearchOrder:=xlByRows, _ LookAt:=xlWhole, _ MatchCase:=False) If FoundCell Is Nothing Then MsgBox "見つかりません", vbCritical GoTo ExitHandler End If With FoundCell 商品登録.txt登録番号.Value = .Value 商品登録.txt商品名.Value = .Offset(0, 1).Value 商品登録.txt型番.Value = .Offset(0, 2).Value 商品登録.txt状況.Value = .Offset(0, 3).Value 商品登録.txt状況.SetFocus End With ExitHandler: Set SearchArea = Nothing Exit Sub End Sub Private Sub cmd更新_Click() Dim lRow As Long lRow = Sheets("廃棄商品").Cells(65536, "A").End(xlUp).Row + 1 With Sheets("廃棄商品") .Cells(lRow, "B").Value = 商品登録.txt登録番号.Value .Cells(lRow, "A").Value = 商品登録.txt商品名.Value .Cells(lRow, "C").Value = 商品登録.txt型番.Value .Cells(lRow, "D").Value = 商品登録.txt状況.Value   End With MsgBox "廃棄商品シートへ登録しました。", vbInformation End Sub

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

  • ベストアンサー
  • rukuku
  • ベストアンサー率42% (401/933)
回答No.2

はじめまして だいたいの状況は分かりますが、詳細までは正確に分からないので「考え方」のアドバイスをします。 >検索したデータを指定するコードがわかりません 検索したデータがあるセルは「FoundCell」にあります。 fumfumponpさんのプログラムの With FoundCell … End With の部分がサンプルプログラムですよ! 問題になる点があるとすれば、「検索」と「更新」のプログラム(プロシージャ)の間で「FoundCell」のデータをやりとりする方法だと思います。 その方法としては以下の2つが思い浮かびました。 1.「DIM」と使って変数を定義するときに、モジュール内では共通に使えるように指定する。  (Sub … End Sub)の外に  Dim FoundCell  を記述する  参考:http://www.k1simplify.com/vba/tipsleaf/leaf330.html 2.隠しBOXにセルのアドレスを記載する  テキストボックスやラベルには「visible」というプロパティがあって、これを「False」とすると、実際には表示されません。  表示されないだけで、実際には存在するので「.value」を使えば内容を読み込むことができます。 文書だけなので、言葉足らずのことはあると思います。 分からない点がありましたら回答を締め切らず、「この回答への補足」に書いてください。 p(^^)q

その他の回答 (1)

  • rukuku
  • ベストアンサー率42% (401/933)
回答No.1

はじめまして だいたいの状況は分かりますが、詳細までは正確に分からないので考え方のアドバイスをします。 >検索したデータを指定するコードがわかりません 検索したデータがあるセルは「FoundCell」にあります。 fumfumponpさんのプログラムの With FoundCell … End With の部分がサンプルプログラムですよ! 問題になる点があるとすれば、「検索」と「更新」のプログラムの間で「FoundCell」のデータをやりとりする方法だと思います。 その方法としては以下の2つが思い浮かびました。 1.「DIM」と使って変数を定義するときに、モジュール内では共通に使えるように指定する。  (Sub … End Sub)の外に  Dim FoundCell  を記述する  参考:http://www.k1simplify.com/vba/tipsleaf/leaf330.html 2.隠しBOXにセルのアドレスを記載する  テキストボックスやラベルには「visible」というプロパティがあって、これを「False」とすると、実際には表示されません。  表示されないだけで、実際には存在するので「.value」を使えば内容を読み込むことができます。 文書だけなので、言葉足らずのことはあると思います。 分からない点がありましたら回答を締め切らず、「この回答への補足」に書いてください。 p(^^)q

fumfumponp
質問者

お礼

rukukuさんありがとうございます。 (1)の方法でやったらできました。 言われるとその通りで、基本的なことを 見落としてました。 ありがとうございます。 >1.「DIM」と使って変数を定義するときに、モジュール内では共通に使えるように指定する。  (Sub … End Sub)の外に  Dim FoundCell  を記述する

関連するQ&A

  • データ検索について

    条件詳細 ・シートは、シートA/シートB。 ・シートAにユーザーフォームを表示するボタンを置く。 ・シートBに商品データ。 ・ユーザーフォームのオブジェクト名は、商品登録。 ・ ユーザーフォームにある項目は、商品番号/商品名/重さの3種類。  ※テキストボックス ・重さは、3種類((1)10kg/(2)20kg/(3)100kg)。 ・検索ボタンを押すと、検索フォームが表示される。 上記条件の下、ユーザーフォームに検索したデータを表示させたいのですが、 私のコードだと、デバックが出てしまい、うまく機能しません。 どのように追加または改造すれば、機能するのか ご教授願います。 私のコードは下記の通りです。 Private Sub cmd検索_Click() Dim SerchKey As String Dim SerchArea As Range lRow = Sheets("商品データ").Cells(65536, "A").End(xlUp).Row + 1 SearchKey = Application.InputBox( _ Prompt:="商品コードを入力して下さい。", Type:=2) If SearchKey = "" Or SearchKey = "False" Then Exit Sub End If Set SearchArea = Sheets("商品データ").Range(Range("A1"), Range("A1").End(xlDown))  ⇒このコードが黄色でデバック! Set FoundCell = SearchArea.Find( _ What:=SearchKey, _ SearchOrder:=xlByRows, _ LookAt:=xlWhole, _ MatchCase:=False) If FoundCell Is Nothing Then MsgBox "見つかりません", vbCritical GoTo ExitHandler End If With FoundCell 商品登録.txt商品コード.Value = .Value 商品登録.txt商品名.Value = .Offset(0, 1).Value 商品登録.txt重さ.Value = .Offset(0, 2).Value End With With Sheets("シートA") If .Cells(lRow, "G").Value = "10kg" Then txt重さ.Value = "0" ElseIf .Cells(lRow, "G").Value = "20kg" Then txt重さValue = "1" ElseIf .Cells(lRow, "G").Value = "100kg" Then txt重さ.Value = "2" End If End With ExitHandler: Set SearchArea = Nothing Exit Sub End Sub 下記がデバック(黄色)が出てしまいます。 Set SearchArea = Sheets("商品ータ").Range(Range("A1"), Range("A1").End(xlDown))   また、10kg/20kg/100kgが数字((1)(2)(3))に変換されません。 If~が機能してないようです。 どのようにしたら良いかお願いします。

  • マクロで検索行・データが入力されている部分を変更したい

    下記4行目に入力されている行は常に変わる為、このままでは検索にかなりの時間が掛かってしまいます。出来ることならデータ入力の最終の行で検索終了したいのですがどうかご教授お願いいたします。 1 Sub Macro1() 2 For a = 1 To 3000 3 snum = Sheets(2).Cells(a, 11) 4 For b = 1 To 200 'ここはSheet1でデータが入力されてる行数 5 If snum = Sheets(1).Cells(b, 1) Then 6 Sheets(2).Cells(a, 12).Value = Sheets(1).Cells(b, 2) 7 Sheets(2).Cells(a, 13).Value = Sheets(1).Cells(b, 3) 8 Sheets(2).Cells(a, 14).Value = Sheets(1).Cells(b, 4) 9 Exit For 10 End If 11 Next 12 Next 13 End Sub

  • Excelのユーザーフォームで別のファイルに転記

    Excel2007です。 マクロを含んだデータファイルがあるのですが、マクロブックとデータブックは分割した方がよいと言われて今分割の方法を試しています。 「マクロブック.xlsm」にマクロを記述し、「商品在庫Data.xlsm」にデータが格納されています。 (まだ試験中で完全に分割できていないのでデータブックもxlsm形式ですが) マクロブックのユーザーフォームから「商品在庫Data.xlsm」ファイルの「商品マスタ」というシートに転記したいのですが、どうやっても「商品在庫Data.xlsm」で「商品マスタ」シートを指定して転記できません。 ユーザーフォームのコードは下記のような内容です。 「HinTouroku」コマンドボタンを押した時に商品マスタシートに内容が転記されるようになっています。 Option Explicit Private Sub HinTouroku_Click() '商品登録 Dim lRow As Long Dim s1 As String, s2 As String Dim Ctrl As Control With Workbooks("商品在庫Data.xlsm") Worksheets ("商品マスタ") lRow = .Range("A" & Rows.Count).End(xlUp).Row s1 = .Cells(lRow, "A").Value s2 = txtHinId.Text If s1 = s2 Then MsgBox "商品IDが重複しています" Exit Sub End If lRow = lRow + 1 .Cells(lRow, "a").Value = txtHinId.Text .Cells(lRow, "b").Value = txtSyohinmei.Text .Cells(lRow, "c").Value = txtHinRyaku.Text End With For Each Ctrl In Me.Controls If Ctrl.Name Like "txt*" Then Ctrl.Value = "" End If Next End Sub Private Sub TourokuClr_Click() '入力フォームのクリア Dim myCtrl As Control For Each myCtrl In Controls If TypeName(myCtrl) = "TextBox" Then _ myCtrl.Value = vbNullString Next End Sub Private Sub TourokuCls_Click() 'フォームを閉じる Unload Me End Sub http://vbaexcel.seesaa.net/category/7604114-2.html このサイトを参考にしながら書いてみたのですがどうしてもシートの指定ができず… どのように記述すればよいのでしょうか?

  • ユーザーホームでの検索について(エクセル)

    コンボボックスで選択した文字とシートの表にある文字が一致か不一致かでMsgBoxに表示させるコードです。 一番上の行を選択しコマンド1ボタンを押すと正常に表示されるが2行目以降を選択すると一致不一致に関わらずすべて注意文が表示されます。  現在シート2,3ともとも10行目までデータがあります。今後データは下の行へと増える予定です。  コマンドボタン1のコード Private Sub cmd検索_Click() Dim i As Long For i = 4 To Sheets("sheet3").Cells(Rows.Count, 3).End(xlUp).Row If Sheets("sheet3").Cells(i, 3) = ComboBox1 Then MsgBox "商品 『 " & Sheets("sheet3").Cells(i, 3).Value & " 』 の在庫数は 『 " & Sheets("sheet3").Cells(i, 9).Value & " 』 です。" Exit Sub Else MsgBox "その商品は登録されていません。", vbExclamation Exit Sub End If Next i End Sub コンボボックスのコード Private Sub UserForm_Initialize() Dim i As Long With Worksheets("sheet2") For i = 4 To .Cells(Rows.Count, 3).End(xlUp).Row ComboBox1.AddItem .Cells(i, 3).Value Next i End With End Sub どこが間違っているのか教えていただけないでしょうか。 よろしくお願いいたします。

  • Excel VBAデータ登録のスピードアップしたい

    下記のようなコードがあります。 ■input データ閲覧・登録・編集シート ■data データを格納するシート inputシートとdataシートでdataの受け渡しを行っているのですが、データレコードを切り替えるだけで20秒ちょっとかかるため、作業効率が悪いです。 この時間を1~2秒ぐらいまで減らすには、どのように修正すれば、いいでしょうか?どうかアドバイスをお願いいたします。 Private Sub datatouroku() ’データを登録する Dim touroku As Integer Dim fRange As Range Set fRange = Sheets("data").Columns(1).Find(What:=Range("BC1").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) touroku = fRange.Row '検索されたNoの行位置を求める Sheets("data").Cells(touroku, 1).Value = Range("BC1:BE1").Value Sheets("data").Cells(touroku, 2).Value = Range("AX1").Value Sheets("data").Cells(touroku, 3).Value = Range("I4").Value   '・・・上記のデータが全部で256件あります。 End Sub ------------------------------------------ Private Sub hyouji() 'データを表示させる Dim fRange As Range Dim kensaku As Long Set fRange = Sheets("data").Columns(1).Find(What:=Range("BC1").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)    If (fRange Is Nothing) Then '見つからなかった?    MsgBox "入力された顧客コードが存在しません。", vbExclamation    Exit Sub    End If    kensaku = fRange.Row '検索された顧客DCの行位置を求める     Range("BC1:BE1").Value = Sheets("data").Cells(kensaku, 1).Value     Range("AX1").Value = Sheets("data").Cells(kensaku, 2).Value    Range("I4").Value = Sheets("data").Cells(kensaku, 3).Value     '・・・上記のデータが全部で256件あります。 Set trg = Sheets("data").Cells(kensaku, 1) End Sub

  • ユーザーフォームを使った検索について

     仕事で使うために、VBAを勉強中ですが、検索の段階でつまずいてしまいました。自分なりに色々やってみたのですが、どうしてもうまくいきません。自分の知識不足が原因なのですが、どこをいじったらよいのかわからないでいます。  シート"一覧"にA列から整理No、職員番号、職種、氏名・・・・という風に、40列、130行程度データが入ります。 ユーザーフォームに複数のテキストボックスを作り、氏名を入力することで、任意のテキストボックスにその行のデータを返すようにしたいのですが、検索すると、アクティブセルの値が表示されます。  よろしくお願いします。 Private Sub cmb検索_Click() Dim frange As Range Dim frow As Long If (txt検索氏名 = "") Then MsgBox "氏名を入力して下さい。", vbExclamation Exit Sub End If Set frange = Worksheets("一覧").Columns(4).Find(what:=txt検索氏名.Text,LookIn:=xlValues, lookat:=xlWhole,searchorder:=xlByRows) If (frange Is Nothing) Then MsgBox "入力された氏名が見つかりませんでした。", vbExclamation Exit Sub End If frow = frange.Row txt検索整理番号.Value = Cells(検索データ行, 1).Value txt検索職名.Value = Cells(検索データ行, 2).Value txt検索職員番号.Value = Cells(検索データ行, 3).Value txt検索氏名.Value = Cells(検索データ行, 4).Value txt検索フリガナ.Value = Cells(検索データ行, 5).Value ’以下40行程度 End Sub

  • セルにデータが入っていないのを見つけるには?

    ユーザフォームにあるコマンドボタンを押すと、Sheet1のセル"D4"から横方向→にセルの中にデータが入っていない所までループし、データが入っていないセルがあったら"END"が入力され終了したいのですが。。 Private Sub CommandButton5_Click() Dim u As Integer u = 4 Do Until Worksheets("Sheet1").Cells(7, u).Value = "" If Worksheets("Sheet1").Cells(7, u).Value = "" Then Worksheets("Sheet1").Cells(7, u).Value = "END" End If u = u + 1 Loop End Sub このコードでは無反応でした。なにがいけないのかご指摘お願いいたします。 ExcelVBAです。

  • エクセルで四者択一の問題を作りたい。・フォーム画面のボタンをクリック、解答、採点画面を出したい。

    一応、フォーム画面で、ボタンをクリックするとデータシートから 持ってきて、それを問題がなくなるまで繰り返したいのですが、うまく いきません。 Private Sub cmd次_click() Dim n As Integer For n = 3 To Cells(Rows.Count, 1).End(xlUp).Row txt設問.Value = Worksheets("データ").Cells(n, 1).Value   txt問1.Value = Worksheets("データ").Cells(n, 2).Value txt問2.Value = Worksheets("データ").Cells(n, 3).Value txt問3.Value = Worksheets("データ").Cells(n, 4).Value txt問4.Value = Worksheets("データ").Cells(n, 5).Value n = n + 1 Next n End Sub Private Sub cmd判定_click() If op3.Value = True Then txt正解.Value = "○" Else txt正解.Value = "×" End If End Sub Private Sub cmd消去_Click() txt設問.Value = "" txt問1.Value = "" txt問2.Value = "" txt問3.Value = "" txt問4.Value = "" txt正解.Value = "" op1.Value = "" op2.Value = "" op3.Value = "" op4.Value = "" End Sub よろしければ、教えていただけないでしょうか?

  • 連続するセルの比較をしたいのですが、(型が一致しません)のエラーが出ます。

     下記のどの部分でエラーになるのか、お教えください よろしくお願いします。  Sub CellsSamp() Sheets("sheet3").Select If Range(Cells(5, 1), Cells(5, 6)) = Range(Cells(5, 8), Cells(5, 25)).Value Then Range(Cells(6, 1), Cells(6, 6)) = Range(Cells(5, 1), Cells(5, 6)).Value End If End Sub

  • VBA で2つのプロシージャを一つにまとめたい

    いつもここにはお世話になっており、ありがとうございます。 さて、タイトルにもありました通り、下記2つのプロシージャでコマンドボタンを設定して、実行しておりますが、これを一つのプロシージャ(ボタン)にまとめたく、ご指導お願いいたします。 ○作ろうとしているVBAの概要 1)EXCELのデータベースで、一枚目の「inputシート」に入力し、2枚目の「dataシート」でデータをどんどん格納していきます。 2)データは、「顧客CDボタン」で管理しており、これをキーとしています。 3)「顧客CD」は[inputシート」ではC4セル、「dataシート」ではA列にで管理しています。 3)データは新規にデータを入力したときの登録ボタン(一つ目のプロシージャ)、既存のデータを編集して、上書きするときの、変更登録ボタン(二つ目のプロシージャ)があります。 ○相談したい内容 「登録ボタン」と「変更」ボタンを一つにまとめて、ひとつのボタンとして、新規にデータを登録するときも、変更したデータを登録するときも、同じボタンで行えるようにしたい。 '■1つ目のプロシージャー Private Sub CommandButton1_Click() '登録ボタン Dim row As Integer row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 2).Value = Range("C5").Value row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 3).Value = Range("C6").Value row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 4).Value = Range("C7").Value row = WorksheetFunction.CountA(Sheets("data").Columns(1)) Sheets("data").Cells(row, 5).Value = Range("F5").Value ActiveWorkbook.Save End Sub '■2つ目のプロシージャー Private Sub CommandButton3_Click() '変更ボタン Dim fRange As Range Dim fRow As Long If (Range("C4").Value = "") Then '顧客CDが入力されていない? MsgBox "顧客コードを入力してください。", vbExclamation Exit Sub End If Set fRange = Sheets("data").Columns(1).Find(What:=Range("C4").Value, _ LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows) If (fRange Is Nothing) Then '見つからなかった? MsgBox "入力された顧客コードが存在しません。", vbExclamation Exit Sub End If fRow = fRange.row '検索された顧客DCの行位置を求める Sheets("data").Cells(fRow, 2).Value = Range("C5").Value Sheets("data").Cells(fRow, 2).Value = Range("C5").Value Sheets("data").Cells(fRow, 2).Value = Range("C5").Value Sheets("data").Cells(fRow, 3).Value = Range("F5").Value