[[20180615150208]]　『ハイパーリンクの作成』（たま）　ページの最後に飛ぶ

『ハイパーリンクの作成』（たま）

ExcelA列２行目以下にある番号と同じファイル名のついたPDFのハイパーリンクをB列にファイル名を付けて作成したいのですがどうしたらよいでしょうか
リンク対象ファイルは２万件ほどありますA列も同様です

条件
１）リストデータA列にファイル名（拡張子なし）記載あり
２）リストデータB列に拡張子込のファイル名を取得、ハイパーリンクを設定
３）リストデータ（取込用VBA入り）は親フォルダ直下
４）取込対象ファイルは親フォルダの中に複数フォルダがあり、その中に格納
５）対応するファイルがない場合はB列に「対象ファイル無し」と記載

お知恵をお貸しいただけないでしょうか
宜しくお願いいたします

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

ハイパーリンク先のPDFが、複数フォルダの中のどのフォルダに存在するのか確定できますか？
（mm） 2018/06/15(金) 16:36

mmさん
複数フォルダにそれぞれPDFデータが格納されており
たとえばAのフォルダは図面
Bのフォルダは仕様書
というようになっています
リストではフォルダ指定なしでただファイル名（拡張子なし）が記載されているだけなのです
なのでAのフォルダでさがしてなければBを探してそれでもなければ次を
という具合になります

宜しくお願いいたします
（たま） 2018/06/15(金) 18:30

同じファイル名が別のフォルダ下に存在したりはしないのですか？丸ごとコピーして古いのを残す、とかやりそうですが。
とりあえず考え方だけ書きます。まず、ブックを置いたフォルダ以下、サブフォルダ含めて全てのファイルのフルパスを得ます。コマンドプロンプトのDIR命令を使うやり方を何度も書いてますので、探してみてください。

フルパス一覧を作成する際、ファイル名だけ別セルに抜き出しておきます。ファイルの更新日時も抜き出しておくと、同名ファイルが存在したときの判断材料になるでしょう。（新しいものを採用すればいい）

後は、元のファイル名一覧とフルパス一覧を比較し、同名があれば一番新しいフルパスを使って、ハイパーリンクを設定すれば良いですね。
（???） 2018/06/15(金) 18:39

???さん
資料の内容別でフォルダが分かれているので同じファイル名は存在しません
始めはリンクを張る元のリストはなく、フォルダも2つだけでしたので
以下のようなVBAをいろいろなHPから参考になるものを探してでっち上げ、使おうと思っていたのですが
後日リストを渡すので、そのリストにハイパーリンクを記述してほしいといわれてしまいました
フォルダの数も増える可能性があるとも言われています
以下のVBAで取得したハイパーリンクを別シートの対応する表に手作業でコピペしてもいいのですが、リンク元ファイルが2万以上あるというので現実的ではないなと思いました

＞後は、元のファイル名一覧とフルパス一覧を比較し、同名があれば一番新しいフルパスを使って、
＞ハイパーリンクを設定すれば良いですね。

ファイルのダブりはないものと考えていますので
単純にハイパーリンクを該当する項目に移す方法があればお教え願えないでしょうか？

以下、HPから調べてでっち上げたVBAです
もっとスマートな方法があるとは思いますがVBAに関してはHPで使えそうなものを探してつぎはぎして使っているだけの素人です
以下の方法ではファイルの拡張子ごとファイル名にしていますが、リンクを張る元リストには拡張子も入っていないので拡張子を除いたファイル名にする必要があります
検索用には拡張子なしで、エクセルセルに記述されるのは拡張子付のファイル名が望ましいので、A・Bがフォルダ１、D・Eがフォルダ２のなかとして
A・D列に検索用拡張子なしファイル名
B・E列に拡張子込のファイル名ハイパーリンク
を入れています
いまはフォルダ2つですが増えた場合を考えるとどうしたらいいでしょうか
2つ目以降のファイルをA列B列の記述に追加で下に入れた方がいいと思うのですが、、
ほんとにはりぼてのVBAですが
もっと効率よくできればそこもお教えいただければ助かります
宜しくお願いいたします

Sub フォルダー内ファイルへのハイパーリンク取得()

Dim SheetName As String
Dim DirName As String
Dim FileName As String
Dim pos As Long

    SheetName = ActiveSheet.Name
    With Worksheets(SheetName)
    i = 2
    j = 1
        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                DirName = .SelectedItems(1)
                Else
                MsgBox "フォルダ選択がキャンセルされました。", vbExclamation
                Exit Sub
            End If
        End With
        FileName = Dir(DirName & "\*.*")
        Do Until FileName = ""
            .Hyperlinks.Add _
            Anchor:=.Cells(i, j + 1), _
            Address:=DirName & "\" & FileName, _
            TextToDisplay:=FileName
            Cells(i, j).Value = Left(FileName, InStrRev(FileName, ".") - 1)
            i = i + 1
            FileName = Dir
        Loop

    i = 2
    j = 4

        With Application.FileDialog(msoFileDialogFolderPicker)
            If .Show = True Then
                DirName = .SelectedItems(1)
                Else
                MsgBox "フォルダ選択がキャンセルされました。", vbExclamation
                Exit Sub
            End If
        End With
        FileName = Dir(DirName & "\*.*")
        Do Until FileName = ""
            .Hyperlinks.Add _
            Anchor:=.Cells(i, j + 1), _
            Address:=DirName & "\" & FileName, _
            TextToDisplay:=FileName
            Cells(i, j).Value = Left(FileName, InStrRev(FileName, ".") - 1)
            i = i + 1
            FileName = Dir
        Loop
    End With
End Sub

（たま） 2018/06/18(月) 10:15

 Sub main()
    Dim FSO As Object, DIC As Object, f As Variant, sf As Variant, c As Range, SHT As Worksheet
    Set SHT = ActiveSheet
    With SHT
        Set FSO = CreateObject("Scripting.FileSystemObject")
        Set DIC = CreateObject("Scripting.Dictionary")
        For Each f In FSO.GetFolder(ThisWorkbook.Path).Files
            If FSO.GetExtensionName(f) = "pdf" Then
                DIC(Split(f.Name, ".")(0)) = f
            End If
        Next f
        For Each sf In FSO.GetFolder(ThisWorkbook.Path).SubFolders
            For Each f In FSO.GetFolder(sf).Files
                If FSO.GetExtensionName(f) = "pdf" Then
                    DIC(Split(f.Name, ".")(0)) = f
                End If
            Next f
        Next sf
        For Each c In .Range("A2:A" & Rows.Count).SpecialCells(2)
            If Not DIC(c.Value) = Empty Then
                c.Offset(, 1).Value = DIC(c.Value)
                .Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=c.Offset(, 1).Value
            Else
                c.Offset(, 1).Value = "該当なし"
            End If
        Next c
    End With
    Set FSO = Nothing
    Set DIC = Nothing
End Sub
（mm） 2018/06/18(月) 12:52

mmさん
ありがとうございます
VBAを記述したエクセルデータと同一上にあるフォルダの中のデータをみて
ハイパーリンクを張っていますね

c.Offset(, 1).Value = DIC(c.Value)
.Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=c.Offset(, 1).Value

ここを以下の様にするセルBにファイルネームのみ記述しますが
うわがきでファイル名が書かれるので、もっといい方法ありますか？
正直、お恥ずかしいですがここに書かれている前半部分の内容の半分も理解できていないのです

c.Offset(, 1).Value = DIC(c.Value)
.Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=c.Offset(, 1).Value, _
TextToDisplay:=c.Value & ".pdf"

こちらのやりたいことはファイルネーム以外実現できています
このソースをみて勉強してみます
ありがとうございました
（たま） 2018/06/18(月) 16:41

c.Offset(, 1).Value = c.Value & ".pdf"

 .Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=DIC(c.Value)
位でいかがですか？
（mm） 2018/06/18(月) 17:30

mmさん
お返事が遅くなり申し訳ありません
ご指摘の様に修正して試したところ
問題なく結果が得られました

FileSystemObjectやDictionaryの部分はWEBで調べて
現在勉強中です
ファイルやフォルダを操作する専用のオブジェクトとか連想配列とか、
使ったことない機能でした

ありがとうございました！
（たま） 2018/06/20(水) 15:26

コメント返信：

[ 一覧(最新更新順) ]

[[20180615150208]] 『ハイパーリンクの作成』（たま） ページの最後に飛ぶ

[[20180615150208]]　『ハイパーリンクの作成』（たま）　ページの最後に飛ぶ