エクセルのマクロで自動的にハイパーリンクしたいです

質問

難しいかもしれませんが、できれば仕事に生かしたいので教えていただきたいと思います。
エクセルのマクロを使って、例えば「別紙明細書」と言う文が入力されたセルだけを自動
的に、「明細書一覧」と言う、同じブック内の、別のシートにハイパーリンクできるようにした
いのですが、どなたかお知恵のある方よろしくお願いいたします。

回答No.5

OrangeCup150 · ベストアンサー

コレクション版です。大量の検索結果（1万件や10万件以上）を対象としない場合はこちらの方法の方が分かりやすいのでおすすめです。

■Module1
' 検索（仮）関数　（名前は要検討）
' Range.Find を繰り返し実行した検索結果をコレクションで返します。
' 引数:
' 検索範囲 - 検索範囲を指定します。
' What, LookIn, LookAt, MatchCase, MatchByte - Range.Find に渡す引数です。
' 備考 何も入力されていないセルを検索にするときには What に Null または Empty を指定します。
' 戻り値:
' 検索結果(Range)をコレクションで返します。
' 検索条件に一致するセルが検索範囲に無いときは Nothing を返します。
Function 検索(検索範囲 As Range, What, Optional LookIn = xlValues, Optional LookAt = xlWhole, Optional MatchCase = False, Optional MatchByte = True) As Collection
If 検索範囲 Is Nothing Then: Set 検索 = Nothing: Exit Function

Dim 検索結果 As Range
Set 検索結果 = 検索範囲.Find(What, LookIn:=LookIn, LookAt:=LookAt, MatchCase:=MatchCase, MatchByte:=MatchByte)
If 検索結果 Is Nothing Then
Set 検索 = Nothing
Else
Set 検索 = New Collection

' 巡回チェックのために初回のアドレスを記憶する
Dim 巡回チェック As String
巡回チェック = 検索結果.Address

Do
検索.Add 検索結果
Set 検索結果 = 検索範囲.FindNext(検索結果)
Loop While Not 検索結果 Is Nothing And 巡回チェック <> 検索結果.Address
End If
End Function

' --------------------------
' 検索（仮）関数の使用例
Sub 別紙明細書が入力されたセルのアドレスをイミディエイトに表示()
Dim 検索結果のコレクション As Collection
Set 検索結果のコレクション = 検索(Application.ActiveSheet.UsedRange, "別紙明細書")

Dim 検索結果 As Range
For Each 検索結果 In 検索結果のコレクション
Debug.Print 検索結果.Address
Next
End Sub

' 検索（仮）関数の使用例　その２
Sub 別紙明細書が入力されたセルにハイパーリンクを設定()
Dim 検索結果のコレクション As Collection
Set 検索結果のコレクション = 検索(Application.ActiveSheet.UsedRange, "別紙明細書")

Dim 検索結果 As Range
For Each 検索結果 In 検索結果のコレクション
Application.ActiveSheet.Hyperlinks.Add 検索結果, vbNullString, "明細書一覧!A1"
Next
End Sub

' 関連　ハイパーリンクの解除
Sub 別紙明細書が入力されたセルのハイパーリンクを解除()
Dim HLink As Hyperlink
For Each HLink In Application.ActiveSheet.Hyperlinks
If HLink.Range.Value = "別紙明細書" Then
' 部分一致の場合は下を使用する
' If HLink.Range.Value Like "*別紙明細書*" Then
HLink.Delete
End If
Next
End Sub

' 関連　ハイパーリンクの解除　その２
Sub ハイパーリンクをすべて解除()
Application.ActiveSheet.Hyperlinks.Delete
End Sub

お礼

色々とご丁寧に教えていただいて有難うございます。
最初に　Sub setHLink()として教えていただいた改造版から
試してみました。
　おかげでなんとか作業ができるようになりました。あとのた
くさん
送っていただた事例も勉強しながら順番に試していきたいと思
います。まずはお礼まで。

回答No.4

OrangeCup150

すみません。字数制限のため連投します。

' オブジェクトがワークシートオブジェクトであるかを検査します。
' 以下のような検査を行う
' Not obj Is Nothing And TypeName(obj) = "Worksheet" And obj.Type = xlWorksheet
' 1. Nothing でないこと
' 2. TypeName 関数が "Worksheet" を返すこと
' 3. Type プロパティを持ち xlWorksheet であること
Function isWorksheet(obj As Object) As Boolean
On Error GoTo ErrorHandler
isWorksheet = False
If Not obj Is Nothing Then
If TypeName(obj) = "Worksheet" Then
If obj.Type = xlWorksheet Then
isWorksheet = True
End If
End If
End If
ErrorHandler:
End Function

大体、マクロの手続きとコールバック関数の組で処理の本質が記述できるようになったので個人的には満足です。
（関数名などは微妙ですが、類似した機能を20個ほど作っても保守しやすくなったかなと）
んー。見直して気づいたけど検索結果(Rangeオブジェクト)を配列かコレクションのようなもので返した方が単純ですね（＾＾；）
処理対象の件数が非常に多いなら処理を途中で中止できるコールバック方式の方が優位ですが・・・。
あと、清書ができていないので読みづらくてすみません。

細かい説明はヘルプの下のリファレンスを参照して下さい。

○　Excel 2007 開発者用リファレンス > リファレンス > Range オブジェクト
Range.Find メソッドを確認して下さい

○　Excel 2007 開発者用リファレンス > リファレンス > Application オブジェクト
Application.Run メソッドを確認して下さい

○　Excel 2007 開発者用リファレンス > リファレンス > Worksheet オブジェクト
Worksheet.Hyperlinks プロパティを確認して下さい
ハイパーリンクの設定はワークシートオブジェクトのプロパティとして保持されています。
つまり、ワークシート単位に保持されています。

○　Excel 2007 開発者用リファレンス > リファレンス > Hyperlinks オブジェクト
Add メソッドを確認して下さい

お礼

まとめてお礼をさせていただきます。ちょっと私にはレベルが
高いですが、なんとかチャレンジさせていただきます。
できるまで、すこしお時間をください。

回答No.3

OrangeCup150

前に作ったマクロをちょっと改造してみました。

■Module1
Sub setHLink()
' 「別紙明細書」が入力されたセルにハイパーリンクを設定します

Application.ScreenUpdating = False

Dim aSheet As Object
Set aSheet = Application.ActiveSheet
If aSheet Is Nothing Or aSheet.Type <> xlWorksheet Then
MsgBox "ワークシートを選択して下さい"
Application.ScreenUpdating = True
Exit Sub
End If
Dim wSheet As Worksheet
Set wSheet = aSheet

With wSheet.UsedRange
Set 検索結果 = .Find("別紙明細書", After:=wSheet.UsedRange(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=True)
' 完全一致検索の場合は下の検索条件を使用する
' Set 検索結果 = .Find("別紙明細書", After:=wSheet.UsedRange(1, 1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, MatchByte:=True)

If Not 検索結果 Is Nothing Then
firstAddress = 検索結果.Address
Do
wSheet.Hyperlinks.Add 検索結果, vbNullString, "明細書一覧!A1"
Set 検索結果 = .FindNext(検索結果)
Loop While Not 検索結果 Is Nothing And 検索結果.Address <> firstAddress
End If
End With

Application.ScreenUpdating = True
End Sub

普通に書いたら上記の様になりますが、ちょっと改造してコールバック関数を使用すると下の様になります。

■Module2
' コールバックする検索関数（検索結果を列挙する関数）

' EnumCellFromFind 関数
' 検索条件に一致するセルを検索し、コールバック関数にそのセル渡します。
'
' 引数:
' 検索範囲 - 検索範囲を指定します。
'
' コールバック - コールバックマクロ関数の名前を指定します。
' コールバック関数の例
'Function CallbackMacro(target As Range) As Boolean
' ' 検索条件に一致したすべてのセルのアドレスを表示します。
' Debug.Print target.Address
' ' False を返すと検索を中止します。 True を返すと検索を継続します。
' CallbackMacro = True
'End Function
'
' What, LookIn, LookAt, MatchCase, MatchByte - Range.Find に渡す引数です。
' 備考 何も入力されていないセルを処理対象にする場合 What に Null または Empty を指定します。
'
' 戻り値: False - 引数の間違いまたはコールバック関数が検索を中断した
' True - 検索が一巡して処理を終了した
'
Function EnumCellFromFind(検索範囲 As Range, コールバック As String, What, Optional LookIn = xlValues, Optional LookAt = xlWhole, Optional MatchCase = False, Optional MatchByte = True) As Boolean
EnumCellFromFind = False
If 検索範囲 Is Nothing Then: Exit Function
If コールバック = vbNullString Then: Exit Function

Dim 検索結果 As Range
Set 検索結果 = 検索範囲.Find(What, LookIn:=LookIn, LookAt:=LookAt, MatchCase:=MatchCase, MatchByte:=MatchByte)
If Not 検索結果 Is Nothing Then
Dim firstAddress As String
firstAddress = 検索結果.Address
Do
If Not Application.Run(コールバック, 検索結果) Then: Exit Do
Set 検索結果 = 検索範囲.FindNext(検索結果)
Loop While Not 検索結果 Is Nothing And 検索結果.Address <> firstAddress
End If
EnumCellFromFind = True
End Function

'------------------------------------
' EnumCellFromFind 関数の利用者側

' マクロ（かんたんな使用例）
' シート１の使用された範囲のなかの未入力のセルを表示します。
Sub MacroPrintNullCell()
EnumCellFromFind Sheet1.UsedRange, "CallbackMacro", Null
End Sub

' コールバック関数
' MacroPrintNullCell マクロが使用します。
' EnumCellFromFind 関数を経由して呼び出だされます。
Function CallbackMacro(target As Range) As Boolean
Debug.Print target.Address
CallbackMacro = True
End Function

'------------------------------------

' マクロ（ハイパーリンクを設定する例）
' アクティブシートの別紙明細書が入力されたセルにハイパーリンクを設定します。
Sub MacroSetHLinkUseEnumCellFromFind()
If isWorksheet(Application.ActiveSheet) Then
EnumCellFromFind Application.ActiveSheet.UsedRange, "CallbackSetHLink", "別紙明細書"
Else
MsgBox "ワークシートを選択して下さい"
End If
End Sub

' コールバック関数
' MacroSetHLinkUseEnumCellFromFind マクロが使用します。
' EnumCellFromFind 関数を経由して呼び出だされます。
Function CallbackSetHLink(target As Range) As Boolean
Application.ActiveSheet.Hyperlinks.Add target, vbNullString, "明細書一覧!A1"
CallbackSetHLink = True
End Function

' オブジェクトがワークシートオブジェクトであるかを検査します。
' 以下のような検査を行う
' Not obj Is Nothing And TypeName(obj) = "Worksheet" And obj.Type = xlWorksheet
' 1. Nothing でないこと
' 2. TypeName 関数が "Worksheet" を返すこと
' 3. Type プロパティを持ち xlWorksheet であること
Function isWorksheet(obj As Object) As Boolean
On Error GoTo ErrorHandler
isWorksheet = False
If Not obj Is Nothing Then
If TypeName(obj)

回答No.2

OrangeCup150

これはシートに「別紙明細書」という文字列が入力されたときに、そのセルにハイパーリンクを設定するというイベント処理なんですが、質問を読み返すと「別紙明細書」が入力されたセルを検索してハイパーリンクを設定するということを意図しているような・・・。
つまり、私の勘違いでした。すみません。

お礼

わざわざ有難うございました。また何かわかったら教えてください。

回答No.1

OrangeCup150

■ThisWorkbook
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Sheet の変更イベントで変更内容をチェックします。
If Target.Value2 Like "別紙明細書" Then
'ハイパーリンクを作成します
Sh.Hyperlinks.Add Target, vbNullString, "明細書一覧!A1"
End If
End Sub

こんな感じですか？

お礼

ありがとうごございました。教えていただいたようにやった
つもりですが、

If Target.Value2 Like "別紙明細書" Then　の所で

止まってしまいます。何故なのかよくわかりません。
解決策があれば教えていただけると幸いです。