アプリ版:「スタンプのみでお礼する」機能のリリースについて

Excelマクロ VBAに関して、ご教示お願いします。

シート1の列Aに「文字列a」~「文字列z」が入力してあるとします。
シート2の列Bにシート1の列Aに入力してある文字列と同じ文字列が
入力してあるのですが、順は不同となります。
この時に、シート1のA列の各文字列にハイパーリンクを設定し、
シート2の同じ文字列へジャンプさせる方法についてご教示お願いします。

シート1      シート2

 A         B
---------------------------------------
 a         d   
 b         a   
 c         b   
 d         c

ご回答いただけますと大変ありがたいです。
よろしくお願い致します。

A 回答 (2件)

こんばんは。



すでに回答がついていますが、もう一度、考えなおしてみてください。

>シート2の同じ文字列へジャンプさせる方法についてご教示お願いします。

VBAだったら、ハイパーリンクを設定しなくても飛べますが・・・。

ジャンプさせる方法。

'シートタブを右クリックして、コードの表示で貼り付ける

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim i As Variant
Dim sh2 As Worksheet
Set sh2 = Worksheets("Sheet2")
Cancel = True
If Target.Column <> 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
i = Application.Match(Target.Value, sh2.Columns(2), 0)
If IsNumeric(i) Then
  Application.Goto sh2.Cells(i, 2)
Else
  MsgBox "該当するセルは見つかりません。", vbExclamation
End If
End Sub

'//

-------------------------
'ハイパーリンクを取り付ける

Sub Main()
Dim sh1 As Worksheet
Dim rng As Range
Dim r1 As Range
Set sh1 = Worksheets("Sheet1")
With sh1
Set r1 = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
End With
For Each rng In r1
 If rng.Value <> "" Then
   Call makeHyperLinks(rng, sh1)
 End If
Next rng
End Sub
Sub makeHyperLinks(rng As Range, sh As Worksheet)
 Dim sh2 As Worksheet
 Dim c As Variant
 Set sh2 = Worksheets("Sheet2")
 Set c = sh2.Columns(2).Find(rng.Value, , xlValues, xlWhole, , False)
 If Not c Is Nothing Then
  sh.Hyperlinks.Add rng, "", sh2.Name & "!" & c.Address(0, 0)
 End If
End Sub
'//
    • good
    • 1

シート名は、sheet1、sheet2としました。


このサイトは字下げが出来ない(前詰になってしまう)為、先行するブランクを_で書いています。
_を半角ブランクに置き換えて下さい。

Sub WK()
____Dim CNT1 As Long
____Dim END1 As Long
____Dim END2 As Long
____Dim FoundCell As Variant
____Dim 位置 As Variant
____Dim 検索値 As Variant
____Dim Sh1 As Worksheet
____Dim Sh2 As Worksheet

____Set Sh1 = Worksheets("sheet1")
____Set Sh2 = Worksheets("sheet2")

____END1 = Sh1.Range("A1").End(xlDown).Row '全体行数取得
____END2 = Sh2.Range("A1").End(xlDown).Row '全体行数取得

____For CNT1 = 2 To END1 '行数分実行
_____検索値 = Sh1.Range("A" & CNT1)

_____Set FoundCell = Sh2.Range("A1:A" & END2).Find(検索値)
______If FoundCell Is Nothing Then
______Else 'ハイパーリンク設定
_______位置 = FoundCell.Address
_______Sh1.Range("A" & CNT1).Hyperlinks.Add Anchor:=Sh1.Range("A" & CNT1), Address:="", SubAddress:="sheet2!" & 位置
_____End If

____Next CNT1

Application.StatusBar = False
End Sub


ハイパーリンク一括削除は以下を実行して下さい
Sh1.Hyperlinks.Delete
  または
Worksheets("sheet1").Hyperlinks.Delete
    • good
    • 1

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています