エクセル 2010 マクロ 検索

質問

http://okwave.jp/qa/q8562170.html
上記質問に追加です。

※1
'D,E,F,G,H,I,K を検索してD,E,F,G,H,I に検索対象があった時
E,F,G,H,Iのいずれかだったら左横列の上に向かって
(EならD　、FならE ・・・という具合に)
何か入力されているセルのM列の191000####をmsgboxで表示させたいです。
(画 F11セル(A-1)が検索ヒットした場合E9セル(R-01)を辿り、
その行のM列のセル(191000####)をmsgboxで表示

※2
但し、検索結果がD列のデータだった時、その行のM列が191000####だった場合
M列の191000####をmsgboxで表示させたいです。
(画 D25セル(Y-1)対象の時)

※3
また、検索結果がD列のデータだった時、その行のM列が191000####以外だった場合
(空白だったり191000####以外の場合)
M列の一番上の191000####をmsgboxで
191000####&「これは例外です」と表示させたいです。
(画 D24セル (X-1)対象の時)

現在のコードは下記のとおりです。

Sheet1に
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address <> "$A$3" Then Exit Sub
Call 検索
Range("A1:A2").Clear
Range("A1").Activate
End Sub

標準モジュールに
Sub 検索()
　Dim Ws1 As Worksheet, Ws2 As Worksheet
　Dim strKey As Variant
　Dim s As String
　Dim c As Range, bln As Boolean
　Dim rng1 As Range
　Dim cnt As Long

　Set Ws1 = Sheet1
　Set Ws2 = Sheet2

　Ws1.Select

　With Ws2
　　strKey = Application.Transpose(.Range("A1").Resize(2).Value)
　　strKey = Join(strKey, "")
　End With

　If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub

　With Ws1
　　Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp))
　　For Each c In rng1.Offset(, -10)

'D,E,F,G,H,I,Kを検索
　　　s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & c.Offset(0, 8).Value & c.Offset(0, 10).Value &

　　　If StrComp(s, strKey, vbTextCompare) = 0 And c.Offset(0, 2).Value = "" Then
　　　　c.End(xlToRight).Activate
c.Offset(0, 2).Value = Date

　　　　c.Resize(1, 14).Interior.ColorIndex = 6
　　　　bln = True
　　　　Exit For
　　　End If
　　Next c

　　If Not bln Then
　　　Ws2.Select
　　　MsgBox "リストに存在しません", vbExclamation, "NotFound"
　　Else '加える
　　　Call ReSearch(Ws1.Range("M2"), c.Row)
　　　'再設定
　　　Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp))
　　　MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation 　　End If
　End With
　Application.Goto Ws2.Range("A1"), True
End Sub

Sub ReSearch(Rng As Range, j As Long)
'最初のセル, 終わりの行数
Dim i As Long
Dim Ws As Worksheet
With Rng.Parent
For i = j To Rng.Row Step -1
If CStr(.Cells(i, Rng.Column).Value) Like "191000####" Then
MsgBox "指図番号 " & vbCrLf & CStr(.Cells(i, Rng.Column).Value) & " の部品です"
Exit For
End If
Next i
End With

End Sub

Function DoubleCountBlank(rng1 As Range, rng2 As Range)
'横並びのセルのブランクをカウントする (セル範囲1 , セル範囲2)
　Dim i As Long
　Dim cnt As Long
　For i = 1 To rng1.Rows.Count
　　If VarType(rng2.Cells(i, 1)) = vbDouble Then
　　　If rng1.Cells(i, 1).Value = "" And rng2.Cells(i, 1).Value <> 0 Then
　　　　cnt = cnt + 1
　　　End If
　　End If
　Next i
　DoubleCountBlank = cnt
End Function

宜しくお願い致します。

回答No.2

WindFaller · ベストアンサー

こんにちは。

Ws2 のA1 とA2 だけを使うというのでしたら、検索方法を変更しました。
以下は、十分にチェックなされていませんので、不具合がありましたら、教えてください。
自分で試した分には、なんとなく、メッセージが何度も出てきて、しっくりきません。
本来は、まとめて出たほうが良いかもしれません。

「私のアレンジ」という部分は、既に検索したものを表示するためのものです。
コメントブロックを外せばメッセージが出ますが、不要なら削除してしまっても良いです。

'//
Sub 検索()
　'ver.0.3 '2014/05/01
　Dim Ws1 As Worksheet, Ws2 As Worksheet
　Dim strKey As Variant
　Dim s As String
　Dim c As Range, bln As Boolean
　Dim rng1 As Range
　Dim cnt As Long

　Set Ws1 = Sheet1
　Set Ws2 = Sheet2

　Ws1.Select　'* Ws2 の画面に時に、Ws1に戻します。

　With Ws2
　　strKey = Trim(.Range("A1").Value) & "," & .Range("A2").Value '*
　　　'Application.Transpose(.Range("A1").Resize(2).Value)
　　　'strKey = Join(strKey, "")
　End With

　If Trim(strKey) = "" Then MsgBox "検索キーが空です", vbCritical: Exit Sub

　With Ws1
　　.Select
　　Set rng1 = .Range("K2", .Cells(Rows.Count, "K").End(xlUp))
　　For Each c In rng1.Offset(, -10)

　　　' 'D,E,F,G,H,I,Kを検索
　　　s = c.Offset(0, 3).Value & c.Offset(0, 4).Value & c.Offset(0, 5).Value & c.Offset(0, 6).Value & c.Offset(0, 7).Value & _
　　　c.Offset(0, 8).Value & "," & c.Offset(0, 10).Value '*

　　　If StrComp(s, strKey, vbTextCompare) = 0 Then
　　　　If c.Offset(0, 2).Value = "" Then '変更を加えた
　　　　　c.Offset(0, 2).Value = Date
　　　　　c.Resize(1, 14).Interior.ColorIndex = 6
　　　　　bln = True
　　　　　If c.Offset(, 2).End(xlToRight).Value <> "" Then '右に検索
　　　　　　Call NumberSearch(c.Offset(, 2).End(xlToRight)) '*番号探し2
　　　　　End If
　　　　　Exit For
　　　　Else
　　　　　'私のアレンジ
　　　　　'MsgBox "コードは見つかりましたが、日付が既に入っています。 " & c.Offset(0, 2).Text, vbExclamation
　　　　End If
　　　End If
　　Next c

　　If Not bln Then
　　　Ws2.Select
　　　MsgBox "リストに存在しません", vbExclamation, "NotFound"
　　Else '加える
　　　Call ReSearch(Ws1.Range("M2"), c.Row)
　　　'再設定
　　　Set rng1 = .Range("K6", .Cells(Rows.Count, "K").End(xlUp))
　　　MsgBox "残り" & DoubleCountBlank(rng1.Offset(, -8), rng1) & "品目です。", vbInformation '*
　　End If
　End With
　Application.Goto Ws2.Range("A1"), True
End Sub

'//新たに付け加えたサブルーチン
Sub NumberSearch(r As Range)
'2014/05/01
Dim i As Long
If r.Column = 4 Then
　 If Cells(r.Row, 13).Value Like "191000####" Then
　　　For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row
　　　　 If Cells(i, "M").Value Like "191000####" Then
　　　　　　 Cells(i, "M").Select
　　　　　　 MsgBox Cells(i, "M").Value, vbInformation
　　　　　　 Exit For
　　　　 End If
　　　Next i
　　ElseIf Not Cells(r.Row, 13).Value Like "191000####" Then
　　　 For i = 2 To Cells(Rows.Count, "K").End(xlUp).Row
　　　　 If Cells(i, "M").Value Like "191000####" Then
　　　　　　 Cells(i, "M").Select
　　　　　　 MsgBox Cells(i, "M").Value & "これは例外です", vbExclamation
　　　　　　 Exit For
　　　　 End If
　　　Next i
　　End If
Else
　 For i = r.Row To 2 Step -1
　　　　 If Cells(i, "M").Value Like "191000####" Then
　　　　　　 Cells(i, "M").Select
　　　　　　 MsgBox Cells(i, "M").Value, vbInformation
　　　　　　 Exit For
　　　　 End If

　 Next i
End If
End Sub

前回の印刷設定の件：
このマクロは、その都度、列幅が紙の横に入らない時は、縮小値が変わるようになっていますが、できれば、固定値の方がよいと思います。場合により、設定時間が掛かることがあるからです。

'//'標準モジュールのみ
Sub TestPrint()
　Dim myRng As Range
　Dim i As Long
　Dim j As Long
　Dim k As Long

　j = 100 '印刷縮小率-初期値100%

　With ActiveSheet
　　Set myRng = .Range("A1", .Cells(Rows.Count, "K").End(xlUp)).Resize(, 14)
　　For i = 1 To myRng.Columns.Count
　　　If i <> 9 Then
　　　　.Columns(i).AutoFit
　　　End If
　　Next i
　　With .PageSetup
　　　.PrintArea = myRng.Address
　　　.Orientation = xlLandscape
　　　.PaperSize = xlPaperA4
　　　.Zoom = j
　　　Do
　　　　k = Application.ExecuteExcel4Macro("COLUMNS(GET.DOCUMENT(65))")
　　　　If k = 1 Then Exit Do
　　　　j = j - 1
　　　　.Zoom = j
　　　Loop
　　End With
　　.PrintOut Preview:=True '印刷プレビューモード:ON-True, OFF-False または取る
　　.PageSetup.Zoom = 100
　End With
End Sub

'//

p.s.質問文を読む限りは、maron1010さんご自身でもコードを組めるレベルに来ているようです。ちょっとの勉強で、特殊なコードを使わない限り、VBAは書けるようになるはずです。

お礼

すみません。
お礼ではないのですが、
印刷で
実行時エラー'1004':
PageSetup クラスの Zoom プロパティを設定できません。　と出て

j = j - 1
.Zoom = j　←」ここが黄色　で止まります。

ただ、何度かに1度、成功する時もありますが
それが何故成功するのかは分かりません。
合わせて宜しくお願いします。

補足

こんにちは。
いつもありがとうございます。

頂いたコードで動かしてみましたが仰る通りメッセージが幾つか出現して
私の思うものと違うので下に書きます。
・の後がmsgboxで表示されます。()内は注釈
←不要★　の部分を修正して頂けると助かります。

検索結果がE～I列のいずれかだった場合
C列に何も入ってなくて検索該当セル行のM列が191000####のデータを検索した時
・(検索該当セル行のM列)191000#### ←不要★
・指図番号191000####の部品です(上と同じ191000####)
・残りXXX品目です

検索結果がE～I列のいずれかだった場合
C列に何も入ってなくて検索該当セル行のM列が191000####以外のデータを検索した時
・(検索該当セル行のM列を上に向かった)191000#### ←不要★
・指図番号191000####の部品です(上と同じ191000####)
・残りXXX品目です

検索結果がE～I列のいずれかだった場合
C列に既に日付が入っていて検索該当セル行のM列が191000####のデータを検索した時
・リストに存在しません

検索結果がE～I列のいずれかだった場合
C列に既に日付が入っていて検索該当セル行のM列が191000####以外のデータを検索した時
・リストに存在しません

検索結果がD列だった場合
C列に何も入ってなくて検索結果行のM列が191000####のデータを検索した時
・(M列の一番上の)191000#### (これは例外です の表示が出ない)
・(検索該当セル行のM列)指図番号191000####の部品です ←不要★
・残りXXX品目です

検索結果がD列だった場合
C列に何も入ってなくて検索結果行のM列が191000####以外のデータを検索した時
・(M列の一番上の)191000####これは例外です
・(検索該当セル行のM列を上に向かった)指図番号191000####の部品です ←不要★
・残りXXX品目です

検索結果がD列だった場合
C列に既に日付が入っていて検索該当セル行のM列が191000####のデータを検索した時
・リストに存在しません

検索結果がD列だった場合
C列に既に日付が入っていて検索該当セル行のM列が191000####以外のデータを検索した時
・リストに存在しません

'私のアレンジ　部分は興味深いのですが、データが入っている回数分msgboxが出現するのでちょっと・・・
ただ、その時、C列の既に日付が入っているセルの.End(xlToRight).Activateに出来たら助かります。

c.Offset(0, 2).Value = Date
c.End(xlToRight).Activate　←ここが無い。ただ、このコードを入れても
ここら↓をアクティブにしてしまう。
If c.Offset(, 2).End(xlToRight).Value <> "" Then '右に検索
Call NumberSearch(c.Offset(, 2).End(xlToRight)) '*番号探し2
D列からI列のいずれのデータをアクティブにしたい。

また、印刷についてですが少し変えさせてください。
I列(9)を　J列(10)に置き換え
J列以降Nまでの幅を　AutoFit
ＡからIまでの列幅を　10とさせたいのですが出来ますでしょうか？
(AからIは隣合うデータが無い為10でも構わないからです)

無理難題ばかりでしょうが、宜しくお願い致します。

回答No.3

WindFaller

maron1010さんへ。

>私の思うものと違うので下に書きます。

私は、以前は、セミプロとしてVBAを書いていた関係上、これ以上は、無料掲示板上では、境界線を越えている感じがします。ある程度、ご自身の課題にしていただけないでしょうか？

体調を崩しているせいか、私は、少し、疲れてしまいました。

勝手なお願いですが、これ以上は、こちらが気が向いたらにしていただけませんか？

お礼

度が過ぎました。すみません。

季節柄、ご自愛ください。

回答No.1

WindFaller

すみません、前回の回答者です。

前回(8562170)の回答の次のリクエストでしたが、実は、言葉だけでは、何度も読み返してみても、わからなくなってしまったからです。それで、回答が付けられなくなってしまいました。

まあ、あまり期待をしないで、お待ちください。（^^;　別の方の回答が良ければ、それでも構いません。
こちらは、図をみて考えてみます。まずは、ご一報だけ。

お礼

ありがとうございます。
前回、素晴らしい回答を頂いたのにも関わらず、自らの不手際で補足にて追加質問などしまして、恐縮していました。
気にかけて頂いているようで、安心しました。
大変理解し難い文章内容かと思いますが、
是非、画像を参考に(・・・なるか分かりませんが)くみ取って頂き、素晴らしい回答を待っています。
よろしくお願いします。