[[20100709142719]]　『ハイパーリンクの自動作成』（fuku）　ページの最後に飛ぶ

『ハイパーリンクの自動作成』（fuku）

[[20050324161946]]を使ってファイルリストを作成させて頂きました。

 個々のデータにハイパーリンクも同時に設定することは可能なのでしょうか。

 データ数が多いので１個ずつリンクさせるのは大変な作業になるので
 なんとかしたいのですが・・・。

 こんな方法もあるよという方がいらっしゃいましたらお願いします。

 XP、EXCEL2007です。

 昔作ったもののコピペです。
 普段の業務で使用しているので、多分ちゃんと動くと思いますが、
 当方はExcel2003です。(osは一緒でxpですが)

 Sub おまけ_FileList()
    Dim Fsys As Object, aFolder As Object, aFile As Object
    Dim A As Long, aPath As String, HLSw As Long
    On Error Resume Next
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        aPath = .SelectedItems(1)
    End With
    If aPath = "" Then Exit Sub
    Set Fsys = CreateObject("Scripting.FileSystemObject")
    Set aFolder = Fsys.GetFolder(aPath)
    HLSw = MsgBox("ハイパーリンクを付加しますか?", vbYesNo + vbQuestion)
    If ActiveWorkbook Is Nothing Then Workbooks.Add
    If ActiveWorkbook.Path <> "" Or Not ActiveWorkbook.Saved Then Workbooks.Add
    A = 1
    Range("A1:H1").Value = Array("Name", "Size", "Type", "DateCreated", "DateLastAccessed", "DateLastModified", "Attributes", "Path")
    Application.StatusBar = "ファイルサイズを計算しています・・・"
    If aFolder.SubFolders.Count = 0 Then GoTo FILES_PHASE
    For Each aFile In aFolder.SubFolders
        A = A + 1
        Cells(A, 1).Value = aFile.Name
        If HLSw = vbYes Then ActiveSheet.Hyperlinks.Add anchor:=Cells(A, 1), Address:=aFile.Path, TextToDisplay:=aFile.Name
        Cells(A, 2).Value = aFile.Size
        Cells(A, 3).Value = aFile.Type
        Cells(A, 4).Value = aFile.DateCreated
        Cells(A, 5).Value = aFile.DateLastAccessed
        Cells(A, 6).Value = aFile.DateLastModified
        Cells(A, 7).Value = aFile.Attributes
        Cells(A, 8).Value = aFile.ParentFolder.Path
    Next
 FILES_PHASE:
    If aFolder.Files.Count = 0 Then GoTo FREE_PHASE
    For Each aFile In aFolder.Files
        A = A + 1
        Cells(A, 1).Value = aFile.Name
        If HLSw = vbYes Then ActiveSheet.Hyperlinks.Add anchor:=Cells(A, 1), Address:=aFile.Path, TextToDisplay:=aFile.Name
        Cells(A, 2).Value = aFile.Size
        Cells(A, 3).Value = aFile.Type
        Cells(A, 4).Value = aFile.DateCreated
        Cells(A, 5).Value = aFile.DateLastAccessed
        Cells(A, 6).Value = aFile.DateLastModified
        Cells(A, 7).Value = aFile.Attributes
        Cells(A, 8).Value = aFile.ParentFolder.Path
    Next
 FREE_PHASE:
    If aFolder.IsRootFolder Then
        A = A + 1
        Cells(A, 1).Value = "(AvailableSpace)"
        Cells(A, 2).Value = aFolder.Drive.AvailableSpace
    End If
    Application.StatusBar = False
    Set aFolder = Nothing
    Set aFile = Nothing
    Set Fsys = Nothing
    Columns("D:F").NumberFormatLocal = "yyyy/mm/dd hh:mm:ss;@"
    Range("A:G").EntireColumn.AutoFit
    Cells(2, 2).Select
    ActiveWindow.FreezePanes = True
    Exit Sub
 Ed:
    MsgBox aFolder.Path & Chr(10) & "にファイルは見つかりませんでした。", vbInformation
    Application.StatusBar = False
    Set aFolder = Nothing
    Set aFile = Nothing
    Set Fsys = Nothing
 End Sub

 ご参考まで・・・

 (白茶)

出来ました。
大変助かりました。有難うございます。（fuku）

コメント返信：

[ 一覧(最新更新順) ]

[[20100709142719]] 『ハイパーリンクの自動作成』（fuku） ページの最後に飛ぶ

[[20100709142719]]　『ハイパーリンクの自動作成』（fuku）　ページの最後に飛ぶ