excel VBA Dirにて検索したフォルダのパスを取得してハイパーリンクを貼る方法

excel VBA Dirにて検索したフォルダのパスを取得してハイパーリンクを貼る方法が知りたいです。

〇部分一致にて検索したフォルダのハイパーリンクを作成したいのですが、うまくいきません。

〇下記は以前こちらで助言頂いて作成した「部分一致にて検索したフォルダを開く」コードとその時の質問リンクです。
https://oshiete.goo.ne.jp/qa/12633599.html

Sub sample()

Dim xFld As String
Const xParent As String = "C:\Users\Desktop\test\"
xFld = Dir(xParent & "*" & Range("I11").Value & "*", vbDirectory)
Do Until xFld = ""
Shell "C:\Windows\Explorer.exe " & xParent & xFld, vbNormalFocus

xFld = Dir
Loop

End Sub
(↑デスクトップ「test」内にある｛「I11」セルの文字列を名前に含むフォルダ｝を開くもの)

〇上記で開くフォルダのハイパーリンクをシートに貼りたい場合どのようにしたら良いか助言頂けると有り難いです。
下記試してうまくいかなかったものの一つです。

Sub sample4()

Dim xFld As String
Const xParent As String = "C:\Usersi\Desktop\test\"
xFld = Dir(xParent & "*" & Range("I11").Value & "*", vbDirectory)
Do Until xFld = ""

Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fl As Folder
Set fl = fso.GetFolder(xFld)

　Dim rng As Range
Set rng = Range("AD2").Offset(i, j)

ActiveSheet.Hyperlinks.Add Anchor:=rng, Address:=fl.Path

i = i + 1

xFld = Dir
Loop

End Sub


何卒宜しくお願い申し上げます。

質問者からの補足コメント

• ご回答ありがとうございます。
  頂いたもの動作しないようです。
  
  エラー
  ■頂いた物動作せず
  ■質問文中コード「パスがみつかりません」
  ■他試作↓Do Until 下部
  Dim fso As FileSystemObject
  Set fso = New FileSystemObject
  Dim s As String
  s = fso.GetBaseName(xFld)
  Dim rng As Range
  Set rng = Range("AD2").Offset(i, j)
  ActiveSheet.Hyperlinks.Add Anchor:=rng, Address:=s
  i = i + 1
  リンク貼付されるが「指定されたファイルを開く事ができません」表示。
  「ハイパーリンクの編集」でアドレスを確認すると「A%20」という表記(フォルダ名「A」)
  
  j要らないですね。

  No.1の回答に寄せられた補足コメントです。 補足日時：2021/10/21 17:40

• 回答ありがとうございます。うまく動作しました。
  （Usersiの部分）はコピペした後の手直しでの消し忘れです。惑わせてすみません。
  i,jに関しては何分初心者の為サイト等見つつ色々組み合わせたりで漏れや不要部あるようで、ご容赦下さい。
  
  ついでに追加質問しても宜しいでしょうか。
  上記だとリンクの文字がアドレスそのもの「C:\Usersi\Desktop\test\フォルダ名」となりますが、こちらをフォルダ名だけにするにはどうしたら良いでしょうか。
  
  お手数お掛け致しますが、回答頂けましたら幸甚です。
  何卒宜しくお願い致します。

  No.3の回答に寄せられた補足コメントです。 補足日時：2021/10/21 17:56

No.5 ベストアンサー 回答者： fujillin 回答日時： 2021/10/21 18:14

No3です

セルに表示する値を設定したいのなら、TextToDisplay の引数を設定すれば良いです。
（ご提示のコードに指定がなかったので、そのままにで回答しました）

具体的には、
ActiveSheet.Hyperlinks.Add Anchor:=Range("AD2").Offset(i), _
Address:=xParent & xFld, TextToDisplay:=xFld
のような感じです。

この回答へのお礼

ありがとうございます。

お礼日時：2021/10/22 10:01

No.4 回答者： mygoonickname 回答日時： 2021/10/21 17:50

No.1の者です。

下記の様な感じのコードを提示したつもりだったのですが。。。
jをどうするか不明なので、そのまま記載しています。
i=i+1の場所を修正しています。

Sub sample4()
Dim xFld As String
Dim i As Long, j As Long
Const xParent As String = "C:\Usersi\Desktop\test\"
xFld = Dir(xParent & "*" & Range("I11").Value & "*", vbDirectory)
With ActiveSheet.Hyperlinks
Do Until xFld = ""
i = i + 1
.Add Anchor:=Range("AD2").Offset(i, j), Address:=xFld
xFld = Dir
Loop
End With
End Sub

この回答へのお礼

ありがとうございました。

お礼日時：2021/10/22 10:01

No.3 回答者： fujillin 回答日時： 2021/10/21 17:15

こんにちは

よくわからないところがありますけれど・・・

見つけたフォルダへのリンクを設定するだけなら、わざわざ FileSystemObject を持ち出してくる必要はありません。
すでにフォルダーのパスはわかっているのですから、文字列連結で
　Address:=xParent & xFld
として設定すれば十分でしょう。

それ以前に、
＞Const xParent As String = "C:\Usersi\Desktop\test\"
は、通常は存在しないパスだと思いますけれど（Usersiの部分）、特殊なフォルダ構成になっているのでしょうか？
また、
＞Set rng = Range("AD2").Offset(i, j)
って、変数 i も j も初期値が設定されていないし、しかも j は何も変化していませんよね？
（VBAの場合は、一応、初期値は””または0に自動で評価はされますけれど・・）


なさりたいことは、「AD2のセルから下方に順にリンクを設定してゆきたい」ということでしょうか？
であるなら、とりあえず、
ActiveSheet.Hyperlinks.Add Anchor:=Range("AD2").Offset(i), Address:=xParent & xFld
などとしておけば、可能と思います。

No.2 回答者： chiune 回答日時： 2021/10/21 16:54

ちゃんと全体見てないですが、

単純なタイプミスかもしれないです。
Const xParent As String = "C:\Usersi\Desktop\test\"
　　　　↓
Const xParent As String = "C:\Users\Desktop\test\"

この回答へのお礼

ありがとうございます。
こちらに記載する時に手直しした文字の消し忘れです。
惑わせてすみません。

お礼日時：2021/10/21 17:42

No.1 回答者： mygoonickname 回答日時： 2021/10/21 16:40

こんにちは。

どの様に、うまくいかなかったのでしょうか？

Dimは、Subのすぐ下にまとめて書いた方が良いかと。
ループで2回目に同じ宣言を通るとエラーになるのでは？
xFld にパスが入っているので、それをリンクとして貼れば良いかと。


Do Until xFld = ""

Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim fl As Folder
Set fl = fso.GetFolder(xFld)

　Dim rng As Range
Set rng = Range("AD2").Offset(i, j)

ActiveSheet.Hyperlinks.Add Anchor:=rng, Address:=fl.Path

i = i + 1

xFld = Dir
Loop


↓

Dim i As Long, j As Long
With ActiveSheet.Hyperlinks
Do Until xFld = ""
.Add Anchor:=Range("AD2").Offset(i, j), Address:=xFld
i = i + 1

xFld = Dir
Loop
End With


変数、jが良く分かりませんが、例えば、上記の様にすれば良いかと。
（何となく、組み合わせで作っているので、詳細は調整して下さい）
動作確認もしていないので、場合によってはエラーになるかも。

下記を参考に、組み立てています。
https://www.moug.net/tech/exvba/0050064.html

この回答へのお礼

前回引き続きご回答ありがとうございます。
エラー内容補足書きました。

お礼日時：2021/10/21 17:43