エクセルのマクロ検索について

質問

みなさんはじめまして。
先日より必要に駆られてエクセルのマクロを使い始めた初心者です。
なかなか独学ではうまくいかず、
皆さんのお知恵を拝借したくお願いします。

したいことは以下の通りです。
検索シートに検索会社を入力すると、一部でも一致するデータを
顧客データが入った別シートから検索し、
検索シートにリストアップすると言うことがしたいです。
データシートには
　Ａ列　　Ｂ列　　　Ｃ列　　　Ｄ列　　　　Ｅ列　　　　　Ｆ列
　分類　　会社名　　担当者　　電話番号　詳細へハイパーリンク　業務内容
　----　　●社　　　Ａさん　　123-4567　　******　　　　XXXX
　----　　×社　　　Ｂさん　　234-5678　　******　　　　????
　----　　△社　　　Ｃさん　　345-6789　　******　　　　!!!!!
などのようにデータが300社くらい入っています。
一応自分で下記のようなマクロを組んでみたのですが、
リストアップされたデータのハイパーリンクの部分が文字列になってリンクとして使えません。
解消方法、またはもっと良いマクロがあれば教示お願いします

Sub 検索()
Dim tmp As Range
Dim y As Integer, a, firstAddress
'***** 結果を表示する部分をクリアします
Sheets("検索").Range("A7:ag65536").ClearContents
'***** キーワードを取得
a = InputBox("検索会社名を入力してください")
'***** キーワードを含むデータを検索
Set tmp = Sheets("検索元データ").Columns(3).Find(a, , , xlPart)
If tmp Is Nothing Then
'***** 見つからない場合
MsgBox "一致するデータはありません"
Else
'***** 見つかった場合
firstAddress = tmp.Address
y = 7
'***** 他にもあるか探してあれば記載
Do
Sheets("検索").Range("c" & y) = tmp
Sheets("検索").Range("b" & y) = tmp.Offset(0, -1)
Sheets("検索").Range("d" & y) = tmp.Offset(0, 1)
Sheets("検索").Range("e" & y) = tmp.Offset(0, 2)
Sheets("検索").Range("f" & y) = tmp.Offset(0, 3)
Sheets("検索").Range("g" & y) = tmp.Offset(0, 4)
Sheets("検索").Range("h" & y) = tmp.Offset(0, 5)
Sheets("検索").Range("i" & y) = tmp.Offset(0, 6)
Sheets("検索").Range("j" & y) = tmp.Offset(0, 7)
Set tmp = Sheets("検索元データ").Columns(3).FindNext(tmp)
y = y + 1
Loop Until tmp.Address = firstAddress
End If
End Sub

回答No.1

fujillin · ベストアンサー

書式もコピーしてしまってよければ、対象レンジをまとめてコピーしちゃうのが一番簡単です
　tmp.Offset(0, -1).Resize(1, 9).Copy (Worksheets("検索").Range("B" & y))

書式はコピーしたくないのであれば、ハイパーリンクだけ別にコピーするとして（Ｅ列ですよね？）
　Worksheets("検索").Range("B" & y).Resize(1, 9).Value = tmp.Offset(0, -1).Resize(1, 9).Value
If tmp.Offset(0, 2).Hyperlinks.Count > 0 Then
　Worksheets("検索").Hyperlinks.Add Anchor:=Worksheets("検索").Range("E" & y), Address:=tmp.Offset(0, 2).Hyperlinks(1).Address
End If
みたいな感じ。（列などがずれていたら訂正願います）

お礼

書式コピーで全然問題ないです。
やってみたところばっちりでした。
ありがとうございます

回答No.3

merlionXX

これでいかがでしょう？

Sub 検索02()
Dim tmp As Range
Dim y As Integer, a, firstAddress
'***** 結果を表示する部分をクリアします
Sheets("検索").Range("A7:AG65536").ClearContents
'***** キーワードを取得
a = InputBox("検索会社名を入力してください")
'***** キーワードを含むデータを検索
Set tmp = Sheets("検索元データ").Columns(3).Find(a, , , xlPart)
If tmp Is Nothing Then
'***** 見つからない場合
MsgBox "一致するデータはありません"
Else
'***** 見つかった場合
firstAddress = tmp.Address
y = 7
'***** 他にもあるか探してあれば記載
Do
tmp.Offset(0, -1).Resize(, 9).Copy Sheets("検索").Range("b" & y).Resize(, 9)
Set tmp = Sheets("検索元データ").Columns(3).FindNext(tmp)
y = y + 1
Loop Until tmp.Address = firstAddress
End If
End Sub

お礼

すみません。
上記式だとエラーがかかってしまいました。

とりあえず下記のお二方の方法にて対応できましたので
今回はこれでいこうと思います。
また何かありましたら、よろしくお願いします。

回答No.2

myRange

代入ではハイパーリンクや書式は移動できませんので、コピーしてください。

Sheets("検索").Range("c" & y) = tmp
Sheets("検索").Range("b" & y) = tmp.Offset(0, -1)
Sheets("検索").Range("d" & y) = tmp.Offset(0, 1)
Sheets("検索").Range("e" & y) = tmp.Offset(0, 2)
Sheets("検索").Range("f" & y) = tmp.Offset(0, 3)
Sheets("検索").Range("g" & y) = tmp.Offset(0, 4)
Sheets("検索").Range("h" & y) = tmp.Offset(0, 5)
Sheets("検索").Range("i" & y) = tmp.Offset(0, 6)
Sheets("検索").Range("j" & y) = tmp.Offset(0, 7)

上記の転記部分を下記の１行と入れ替える

tmp.EntireRow.Copy Sheets("検索").Range("A" & y)

お礼

やってみたらばっちり出来ました。
ありがとうございます。