エクセルＶＢＡで検索表示

質問

エクセルＶＢＡを使い検索する方法を教えて下さい。
作業登録というシートは
　　　Ａ　　　　　　Ｂ
１　作業名　　作業完了月日　　
２　○○
３　××
４　△△
・
・
と日々５件ぐらい追加され年間では５００件ぐらいつまり５００行くらい使います。
また作業入力というシートは
　　　Ａ　　　　Ｂ　　　　Ｃ　　　Ｄ
１　作業日　作業名　完了　継続
２　12/23　　○○　　　　　　○
３　12/23　　××　　　○
・
・　12/24　　△△
・
と当日の作業を作業登録シートから作業名をコピー入力し、夕方その作業が終われば完了に○、終わらなければ継続に○を入力します。翌日になれば、最終入力行から前日と同様に入力し夕方になれば完了・継続欄に入力と毎日このような処理をし、１年間このシートに入力するため１万行ぐらいになります。
ここからが質問ですが
作業登録シートにコマンドボタンを置きクリックしたら作業入力シートで完了欄に○がついている作業名があったらその行の日付を作業完了月日の該当する欄に表示させ、かつ該当作業名セルを奇数月は赤色、偶数月は黄色に塗りつぶしたいのです。
月締めの検収時、作業入力シートでオートフィルを使い終わっている作業名を検索し処理していますが、もっと早く処理したいのです。ちなみに同じ作業名はありませんし、継続作業は完了するまで何日（連続とは限らない）も作業します。また終わった作業は再び実施しません。
よろしくお願いします。

回答No.4

ja7awu · ベストアンサー

#３ですが、ちょっと確認と訂正です。

提示のシート状況では、「作業日」に「年」が無く「月日」だけですが、このコードは、
「日付と認識できる書式」になっていることが、条件です。
表示形式をユーザー定義で mm/dd にしている場合は、ＯＫです。

なお、#3のコードは、テスト用に「作業登録」シートのデータ範囲を限定したままですので、
こちらのコードに訂正します。（22行目を Range("A:A") に変更）

どちらかのシートにコマンドボタンを配置し、そのクリック時イベントに次のように
記述します。
（配置したコマンドボタンをＷクリックしたコードウィンドウに記述します。）

必要により、「設定事項」を変更してください。

これで提示のシート状況では、希望どおり動作すると思います。

Private Sub CommandButton1_Click()
'------- 設定事項 ---------
Const Sh1 = "作業登録" ' <----- シート名を指定
Const Sh2 = "作業入力" ' <-----　　〃
Const CLR_Kanryoubi = 1 ' <-- 1=作業完了日をクリア後、現データを転記する: 0=しない
Const CLR_Color = 1 '　　 <-- 1=全体の作業名の色を戻して現データで着色:　0=しない
'--------------------------
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim Rng As Range
Dim R As Range
Set WS1 = Worksheets(Sh1)
Set WS2 = Worksheets(Sh2)
If CLR_Kanryoubi = 1 Then
　　WS1.Range("B2:B65536").ClearContents
End If
If CLR_Color = 1 Then
　　WS1.Range("A2:A65536").Interior.ColorIndex = xlNone
End If
For Each Rng In WS2.Range("C2", WS2.Range("C65536").End(xlUp))
　　If Rng.Value = "○" Then
　　　　Set R = WS1.Range("A:A").Find(Rng.Offset(, -1).Value, _
　　　　　　lookat:=xlWhole)
　　　　If R Is Nothing Then
　　　　　　MsgBox Sh1 & "シートに 【 " & Rng.Offset(, -1).Value & _
　　　　　　" 】 の作業名が見つかりません。", vbCritical
　　　　Else
　　　　　　R.Offset(, 1).Value = Rng.Offset(, -2).Value
　　　　　　If Month(R.Offset(, 1).Value) Mod 2 = 1 Then
　　　　　　　　R.Interior.ColorIndex = 40 ' 赤=3
　　　　　　Else
　　　　　　　　R.Interior.ColorIndex = 36 ' 黄=6
　　　　　　End If
　　　　End If
　　End If
Next Rng
Set WS1 = Nothing
Set WS2 = Nothing
Beep: Beep: Beep
MsgBox Sh1 & " シートに 作業完了月日 を転記しました。", vbInformation
End Sub

補足

ありがとうございます。思い通りのことができました。しかも説明つきで大変助かります。私も本を買ってトライしましたが駄目でした。そこで甚だ申し訳ありませんが、これに関連してもう一つ教えて下さい。
作業入力シートにある同じ作業名を複数回完了の○がついたら、作業登録シートの該当作業名のとなり（最初の質問では作業完了月日の欄）にその完了回数を表示たいのです。つまり作業登録シートにある作業を複数回完了させなければならないという条件で、過去何回完了したかを表示させたいのです。ＶＢＡに関し知っている知人がいなく困っています。よろしくお願いします。

回答No.6

ja7awu

追加質問の回答です。

「作業登録」シートの１行が見出しで A列が「作業名」、B列が「完了回数」とします。

前回と違うコマンドボタンを配置し、そのクリック時イベントに次のように記述します。
ボタンをクリックすると「完了回数」が表示されます。

Private Sub CommandButton2_Click()
'------- 設定事項 ---------
Const Sh1 = "作業登録" ' <----- シート名を指定
Const Sh2 = "作業入力" ' <-----　　〃
'--------------------------
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim Rng As Range
Dim R As Range
Set WS1 = Worksheets(Sh1)
Set WS2 = Worksheets(Sh2)
WS1.Range("B2:B65536").ClearContents
WS1.Range("B2:B65536").NumberFormatLocal = "G/標準"
For Each Rng In WS2.Range("C2", WS2.Range("C65536").End(xlUp))
　　If Rng.Value = "○" Then
　　　　Set R = WS1.Range("A:A").Find(Rng.Offset(, -1).Value, _
　　　　　　lookat:=xlWhole)
　　　　If R Is Nothing Then
　　　　　　MsgBox Sh1 & "シートに 【 " & Rng.Offset(, -1).Value & _
　　　　　　" 】 の作業名が見つかりません。", vbCritical
　　　　Else
　　　　　　R.Offset(, 1).Value = R.Offset(, 1).Value + 1
　　　　End If
　　End If
Next Rng
Set WS1 = Nothing
Set WS2 = Nothing
Beep: Beep: Beep
MsgBox Sh1 & " シートに 作業完了回数 を転記しました。", vbInformation
End Sub

お礼

クリスマスイブの夜に再度質問したら朝には回答が来るなんてビックリしてます。実は昨日１日この問題に本を片手にトライしましたが駄目でした。その回答がたった１行の（R.Offset(, 1).Value = R.Offset(, 1).Value + 1）で済むなんて、ＶＢＡて本当難しいです。回答は望んでいたもので、完璧です。ありがとうございました。

回答No.5

imogasi

Find,FindNextにこだわったために余りよいものになっていませんが、参考になれば。よろしく。コマンドボタン・クリックで動くようにしてないのと、セルの色づけは省略しました。シート名、Range、配列の要素数など修正してください。
(データ例）
Sheet１のA1:C11
日付 プロジェクト 完了
2003/12/11 大阪 ○
2003/12/23 dd
2003/12/24 fff
2003/11/30 gg
2003/12/23 東京 ○
2003/12/24 ｊｊ
2003/12/25 fff ○
2003/12/26 gg
2003/12/27 名古屋 ○
2003/12/28 ｋｋ
(コード）
Sub test01()
Dim c1(10)
Dim c2(10)
Dim x As Range
Dim m As Range
Worksheets("sheet1").Activate
Set m = Range("a1")
j = 1
m.Select
Set x = Worksheets("sheet1").Range("c1:c20").Find(what:="○")
If Not (x Is Nothing) Then 'B1
x.Activate
If m.Row >= x.Row Then Exit Sub
u = x.Offset(0, -1)
v = x.Offset(0, -2)
Set m = x
c1(j) = u: c2(j) = v
j = j + 1
Worksheets("sheet1").Activate
p01:
Set x = Worksheets("sheet1").Range("c1:c20").FindNext(ActiveCell)
'--------
If Not (x Is Nothing) Then 'A1
x.Activate
If m.Row >= x.Row Then GoTo p04
u = x.Offset(0, -1)
v = x.Offset(0, -2)
Set m = x
c1(j) = u: c2(j) = v
j = j + 1
Worksheets("sheet1").Activate
Set m = x
GoTo p01
Else 'A2
MsgBox "これ以上なし"
GoTo p04
End If 'A3
'-------
Else 'B2
MsgBox "全くなし"
End If 'B3
'-------
p04:
For k = 1 To j
u = c1(k): v = c2(k)
MsgBox u & v
test02 u, v
Next k
End Sub
Sub test02(u, v)
Dim x2 As Range
Dim m2 As Range
Worksheets("sheet2").Activate
Range("B1").Select
Set x2 = Worksheets("sheet2").Range("B1:B20").Find(what:=u)
'-----
If Not (x2 Is Nothing) Then 'B1 =U
x2.Select
If x2.Offset(0, -1) = v Then 'A1 =V
x2.Offset(0, 1) = v
GoTo p02
Else 'A2 <>V
Set m2 = x2
'============
p01:
Set x2 = Worksheets("sheet2").Range("B1:B10").FindNext(x2)
'-----
If Not x2 Is Nothing Then 'C1 =U
x2.Activate
If m2.Row >= x2.Row Then GoTo p02
If x2.Offset(0, -1) = v Then 'D1 =V
x2.Offset(0, 1) = v
GoTo p02
Else 'D2 <>V
Set m2 = x2
GoTo p01
End If 'D3
Else 'C2 <>U
GoTo p02
End If 'C3
'-------
End If 'A3
Else 'B2 <>U
GoTo p02
End If 'B3
p02:
End Sub
（結果）
Sheet2にB1:C5
プロジェクト 完了日
東京 2003/12/23
名古屋 2003/12/27
大阪 2003/12/11
fff 2003/12/25

回答No.3

ja7awu

どちらかのシートにコマンドボタンを配置し、そのクリック時イベントに次のように
記述します。
（配置したコマンドボタンをＷクリックしたコードウィンドウに記述します。）

必要により、「設定事項」を変更してください。

これで提示のシート状況では、希望どおり動作すると思います。

Private Sub CommandButton1_Click()
'------- 設定事項 ---------
Const Sh1 = "作業登録" ' <----- シート名を指定
Const Sh2 = "作業入力" ' <-----　　〃
Const CLR_Kanryoubi = 1 ' <-- 1=作業完了日をクリア後、現データを転記する: 0=しない
Const CLR_Color = 1 '　　 <-- 1=全体の作業名の色を戻して現データで着色:　0=しない
'--------------------------
Dim WS1 As Worksheet
Dim WS2 As Worksheet
Dim Rng As Range
Dim R As Range
Set WS1 = Worksheets(Sh1)
Set WS2 = Worksheets(Sh2)
If CLR_Kanryoubi = 1 Then
　　WS1.Range("B2:B65536").ClearContents
End If
If CLR_Color = 1 Then
　　WS1.Range("A2:A65536").Interior.ColorIndex = xlNone
End If
For Each Rng In WS2.Range("C2", WS2.Range("C65536").End(xlUp))
　　If Rng.Value = "○" Then
　　　　Set R = WS1.Range("A2:A100").Find(Rng.Offset(, -1).Value, _
　　　　　　lookat:=xlWhole)
　　　　If R Is Nothing Then
　　　　　　MsgBox Sh1 & "シートに 【 " & Rng.Offset(, -1).Value & _
　　　　　　" 】 の作業名が見つかりません。", vbCritical
　　　　Else
　　　　　　R.Offset(, 1).Value = Rng.Offset(, -2).Value
　　　　　　If Month(R.Offset(, 1).Value) Mod 2 = 1 Then
　　　　　　　　R.Interior.ColorIndex = 40 ' 赤=3
　　　　　　Else
　　　　　　　　R.Interior.ColorIndex = 36 ' 黄=6
　　　　　　End If
　　　　End If
　　End If
Next Rng
Set WS1 = Nothing
Set WS2 = Nothing
Beep: Beep: Beep
MsgBox Sh1 & " シートに 作業完了月日 を転記しました。", vbInformation
End Sub

回答No.2

ki-aaa

#1です、すみません間違えました。
間違い
>次のコードを、作業登録のシートのイベントに貼り付けてください
正解
次のコードを、作業入力のシートのイベントに貼り付けてください

回答No.1

ki-aaa

>作業登録シートにコマンドボタンを置きクリックしたら作業入力シートで完了欄に○がついている作業名があったらその行の日付を作業完了月日の該当する欄に表示させ、
これをC列に○を入力したら、作業登録というシートの作業完了日に作業日を貼り付けるにしました。

次のコードを、作業登録のシートのイベントに貼り付けてください。C列に○を入力したら自動的に動きます。

Private Sub Worksheet_Change(ByVal Target As Range)
Dim 行 As Long
On Error GoTo 9999
If Target.Column <> 3 Then Exit Sub
If Target.Value <> "○" Then Exit Sub
Worksheets("作業登録").Select
行 = Application.WorksheetFunction.Match _
(Target.Offset(0, -1).Value, Worksheets("作業登録").Range("A:A"), 0)
Worksheets("作業登録").Range("B" & 行) = Target.Offset(0, -2)
Application.Wait (Now + TimeValue("0:00:02"))
Worksheets("作業入力").Select
Exit Sub
9999:
MsgBox "作業名がありません"
Worksheets("作業入力").Select
End Sub

>作業名セルを奇数月は赤色、偶数月は黄色に塗りつぶしたいのです。

これは、条件付書式でやります。

まず、A列を選択します。
次ぎに、書式→条件付書式とします。
条件一　数式がを選び、=B1=""と入れます。
条件ニ　数式がを選び、=(MONTH(B1)/2=INT(MONTH(B1)/2))と入れ、書式をセットします。
条件三　数式がを選び、=(MONTH(B1)/2<>INT(MONTH(B1)/2))と入れ、書式をセットします

>当日の作業を作業登録シートから作業名をコピー入力し
これも、マクロでやれます。