エクセル 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
宜しくお願い致します。
お礼
ありがとうございました！狙い通りの値がKに反映しました。同じ日に申請者が重複しない前提ですので、こちらの式をうまく利用したいです。助かりました。