エクセル 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
宜しくお願い致します。
お礼
質問してから、Exit Subの位置が違うのに 気が付いて、そこかなと修正しても、まだ駄目でした。 今回教えていただいたので、うまく行きました。 Findで見つからなかったらプログラム停止、 見つかったら、上の2文は、その列番号だけを 下の2文はその行番号だけを変数に格納して 次の実行に移したいので、教えていただいたのから 以下のように変更し、思ったように動きました。 IF文はEnd Ifさえあれば、Elseは無くても いいと思っていたのですが.... As Range にしたので、Rangeオブジェクト?だから Setの文の所で、.Columnや.Rowをつけて の列番号のみ、行番号のみの取得は、やはり駄目で 番地を取得させないと駄目なのでしょうか? まだなぜ駄目だったか、わからないでいます。 教えていただき助かりました。 ありがとうございました。 Dim みかん As Range Dim りんご As Range Dim 大箱 As Range Dim 小箱 As Range Dim 検索行番号 Dim 判定列番号 Dim 検索列番号1 Dim 検索列番号2 Set みかん = Rows(1).Find("みかん") If みかん Is Nothing Then MsgBox "1行目に、みかんが有りません。" Exit Sub Else 検索行番号 = Rows(1).Find("みかん").Column End If Set りんご = Rows(1).Find("りんご") If りんご Is Nothing Then MsgBox "一行目に、りんごが有りません。" Exit Sub Else 判定列番号 = Rows(1).Find("りんご").Column End If Set 大箱 = Range("B:B").Find("大箱") If 大箱 Is Nothing Then MsgBox "B列に、大箱が有りません。" Exit Sub Else 検索列番号1 = Range("B:B").Find("大箱").Row End If Set 小箱 = Range("B:B").Find("小箱") If 小箱 Is Nothing Then MsgBox "B列に小箱が有りません。" Exit Sub Else 検索列番号2 = Range("B:B").Find("小箱").Row End If