マクロコードの修正を教えてください。

先日、こちらでコードを教えて頂き、早速使わせてもらっていますが、
作業をこなすうちにさらに追加したい項目が出来ました。
先日の質問はこちらです。
http://oshiete.goo.ne.jp/qa/8654316.html

エクセルのマクロコードで以下のような操作をしています。

７０００名あまりのリスト（Sheet1のA1:A7000に名前、B1:B7000まで持ち点)から
任意の１～３０名あまりの名前を一括検索して、その持ち点を調べるために
一括表示させています。
リストに名前が無い場合でも一括検索する時があります。

下記のコードは、一括検索で含まれない名前は検索から除外され
Sheet2のＡ列（名前）Ｂ列（持ち点）に表示されないようになって
結果が出ます。

これをSheet1（D1:D30)で一括検索で打ち込んだ名前を
リスト内で確認できなくても、そのまま検索した名前だけを
Sheet2に表示させるように追加するにはどのようにすれば宜しいでしょうか？

リストに無い名前はそのまま名前だけ表示されれば結構です。

使用しているコードは以下のとおりです。

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub 連続検索()
'★(1)型宣言
Dim r As Range, c As Range
Dim i As Long, fAd As String
Dim sname As String, srng As String
Dim strow As Long, stcol As Long

'★(2)出力先のシート名と開始セル
sname = "Sheet2"
srng = "A1"

'★(3)開始行、列の取得
strow = Range(srng).Row
stcol = Range(srng).Column

'★(4)出力先の削除
With Sheets(sname)
.Range( _
.Cells(strow, stcol), _
.Cells(.Cells(Rows.Count, stcol).End(xlUp).Row, stcol + 1) _
).ClearContents
End With

For Each r In Range("D1:D30") '指定の各検索文字につき
Set c = Selection.Find(What:=r.Value, LookAt:=xlPart) '選択範囲を検索
If Not c Is Nothing Then 'あったら
fAd = c.Address 'セル番地を控える
Do '繰り返す
i = i + 1 'カウント
'★(5)一致した文字列・値を出力
Sheets(sname).Cells(strow - 1 + i, stcol).Value = c.Value
Sheets(sname).Cells(strow - 1 + i, stcol + 1).Value = c.Offset(0, 1).Value
'★(6)着色をコメントアウト
'c.Interior.ColorIndex = 8 'セル着色
Set c = Selection.FindNext(c) '連続検索
Loop Until c.Address = fAd '一巡するまで'繰り返し
End If
Next r '次の検索文字で繰り返す
Set c = Nothing
MsgBox i & "件を発見しました。", vbInformation, " （￣ー￣）v"
End Sub

＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

どうぞ宜しくお願い致します。

No.1 ベストアンサー 回答者： nishi6 回答日時： 2014/06/29 23:45

質問者様作成のモジュールと解釈して見させてもらいました。

多分、後半にElse以下５行を追加すればいいでしょう。

「Selection」の意味が分からないので何とも言えませんが、実際のデータだけ選択していれば。「D1:D30」に未入力があった場合も「If r.Value <> "" Then」で出力しないでしょう。

Messageについては触っていません。「発見」の一部です。

机上の解答です。確認してください。


　　　　Loop Until c.Address = fAd '一巡するまで'繰り返し
　　Else　'■ここから
　　　　If r.Value <> "" Then
　　　　　　i = i + 1 'カウント
　　　　　　Sheets(sname).Cells(strow - 1 + i, stcol).Value = r.Value
　　　　End If　'■ここまで
　　End If
Next r '次の検索文字で繰り返す

この回答への補足

ご回答誠にありがとうございます。
今、試してみました。
バッチリです。
大変助かりました。m(_ _)m

補足日時：2014/06/30 14:35