[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ハイパーリンクの作成』(たま)
ExcelA列2行目以下にある番号と同じファイル名のついたPDFのハイパーリンクをB列にファイル名を付けて作成したいのですがどうしたらよいでしょうか
リンク対象ファイルは2万件ほどありますA列も同様です
条件
1)リストデータA列にファイル名(拡張子なし)記載あり
2)リストデータB列に拡張子込のファイル名を取得、ハイパーリンクを設定
3)リストデータ(取込用VBA入り)は親フォルダ直下
4)取込対象ファイルは親フォルダの中に複数フォルダがあり、その中に格納
5)対応するファイルがない場合はB列に「対象ファイル無し」と記載
お知恵をお貸しいただけないでしょうか
宜しくお願いいたします
< 使用 Excel:Excel2010、使用 OS:Windows7 >
宜しくお願いいたします
(たま) 2018/06/15(金) 18:30
フルパス一覧を作成する際、ファイル名だけ別セルに抜き出しておきます。 ファイルの更新日時も抜き出しておくと、同名ファイルが存在したときの判断材料になるでしょう。(新しいものを採用すればいい)
後は、元のファイル名一覧とフルパス一覧を比較し、同名があれば一番新しいフルパスを使って、ハイパーリンクを設定すれば良いですね。
(???) 2018/06/15(金) 18:39
>後は、元のファイル名一覧とフルパス一覧を比較し、同名があれば一番新しいフルパスを使って、
>ハイパーリンクを設定すれば良いですね。
ファイルのダブりはないものと考えていますので
単純にハイパーリンクを該当する項目に移す方法があればお教え願えないでしょうか?
以下、HPから調べてでっち上げたVBAです
もっとスマートな方法があるとは思いますがVBAに関してはHPで使えそうなものを探してつぎはぎして使っているだけの素人です
以下の方法ではファイルの拡張子ごとファイル名にしていますが、リンクを張る元リストには拡張子も入っていないので拡張子を除いたファイル名にする必要があります
検索用には拡張子なしで、エクセルセルに記述されるのは拡張子付のファイル名が望ましいので、A・Bがフォルダ1、D・Eがフォルダ2のなかとして
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
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
.Hyperlinks.Add Anchor:=c.Offset(, 1), Address:=DIC(c.Value) 位でいかがですか? (mm) 2018/06/18(月) 17:30
FileSystemObjectやDictionaryの部分はWEBで調べて
現在勉強中です
ファイルやフォルダを操作する専用のオブジェクトとか連想配列とか、
使ったことない機能でした
ありがとうございました!
(たま) 2018/06/20(水) 15:26
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.