エクセル 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
宜しくお願い致します。
お礼
長々と書いてしまったマクロを紐解いて頂きありがとうございます。 この機能知りませんでした、ありがとうございます。 お恥ずかしい話ですが、 これで確認して、とんでもなくズレた値が変数に入っていたせいで、元データの空欄セルを参照する形になってたことが分かりました。 変数に代入するものを修正したところ、正常に機能しました。