excel VBA フォルダ内のサブフォルダを検索してハイパーリンクを貼りたい

締切済

質問者：doratotoisu
質問日時：2021/10/25 11:59
回答数：1件

excel VBA フォルダ内のサブフォルダを検索してハイパーリンクを貼る方法を知りたいです。

フォルダ内のフォルダ群の名前を部分一致で検索して抽出されたもののハイパーリンクをシートに一覧表示したいです。

〇状況
対象フォルダ＝"C:\Users\Desktop\test\"
上記「test」フォルダ内にフォルダ群
「A類」「B類」「C類」...というフォルダがあり、
ABC...各フォルダの中にそれぞれ「管理番号_商品名_パーツ名」で名付けられたフォルダ群があったとします。

このパーツ名を検索ワードとしてtest内のABC...全てのサブフォルダ内の該当フォルダを検索して、そのハイパーリンクを作成したいです。

良い方法があれば教えて頂けますと有り難いです。

下記に作ってみたもののうまく動作しなかったものを貼ります。
(VBA初心者の為、わけわからないコードになっているかと思いますが一応状況参考に。)
Range("I11").Value に検索ワードを入れる設定です。

--------------------------------------------
Sub folderloopパーツ検索()

Dim ws As Worksheet
Dim pt As String

Set ws = ActiveSheet
pt = "C:\Users\Desktop\test\"

Call フォルダリンク一覧取得(pt, ws, t_row)
End Sub
----------
Sub フォルダリンク一覧取得(pt As String, ws As Worksheet, t_row As Long)
Dim FSO As Object
Dim fd As String
Dim s_fd As Object

fd = Dir(pt & "\", vbDirectory)

Do Until fd = ""

Set FSO = CreateObject(Scripting.FileSystemObject)
For Each s_fd In FSO.GetFolder(pt).SubFolders

Dim xFld As String
xFld = Dir("*" & Range("I11").Value & "*", vbDirectory)

Do Until xFld = ""

ActiveSheet.Hyperlinks.Add Anchor:=Range("AC2").Offset(i), Address:=fd & xFld, TextToDisplay:=xFld

i = i + 1

xFld = Dir
Loop

Next s_fd
Set FSO = Nothing

Loop

End Sub
------------

上記コードの不具合部分のご指摘でも、全く別のうまいやり方でも何でも歓迎です。
何かアドバイスや回答を頂戴出来ればと思います。

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