显示同一文件夹内各工作簿名称形成超连接，如果有新增工作簿时可自动更新

张青青

请教各位高手，我要显示同一文件夹内各工作簿名称形成超连接，如果有新增工作簿时可自动更新，要怎么做到呢？请路过高手指点。

3190496160

Sub 建立目录()
Dim ar()
f = Dir(ThisWorkbook.Path & "\*.xls*")
Do While f <> ""
    If f <> ThisWorkbook.Name Then
        n = n + 1
        ReDim Preserve ar(1 To n)
        ar(n) = f ' Split(f, ".")(0)
    End If
f = Dir
Loop
With Sheet1
     rs = .Cells(Rows.Count, 1).End(xlUp).Row
     .Range("a2:a" & rs + 1) = Empty
     .[a2].Resize(n, 1) = Application.Transpose(ar)
End With
End Sub

3190496160

Private Sub Worksheet_SelectionChange(ByVal T As Range)
If T.Row > 1 And T.Column = 1 Then
    If T.Count > 1 Then End
    If T.Value = "" Then End
    f = Dir(ThisWorkbook.Path & "\" & T.Value)
    If f <> "" Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
End If
End Sub

3190496160

测试.rar (36.52 KB, 下载次数: 8)

2021-11-1 08:20 上传

点击文件名下载附件

3190496160

打开文件启用宏，自动建立文件目录，单击A列单元格，自动打开相应文件

xiangbaoan

1. Sub test1()
   
2.   Dim p As String, f As String, r As Long
   
3.   r = 2
   
4.   Range("A1") = "工作簿名"
   
5.   Range("A1").CurrentRegion.Columns(1).Offset(1).Clear
   
6.   p = ThisWorkbook.Path & "\"
   
7.   f = Dir(p & "*.xls?")
   
8.   While Len(f)
   
9.     If f <> ThisWorkbook.Name Then
   
10.       ActiveSheet.Hyperlinks.Add Range("A" & r), p & f, "", "点击链接到 " & f, Split(f, ".xls")(0)
    
11.       r = r + 1
    
12.     End If
    
13.     f = Dir
    
14.   Wend
    
15.   With Range("A1").CurrentRegion.Columns(1)
    
16.     .Borders.LineStyle = 1
    
17.     .Font.Underline = -4142
    
18.   End With
    
19. End Sub

复制代码

张青青

3190496160 发表于 2021-11-1 08:21
打开文件启用宏，自动建立文件目录，单击A列单元格，自动打开相应文件

大侠您好！已测试，能实现。非常感谢！但如果有新增文件时须关闭目录文件后重新打开，目录里才能显示新增的文件。

张青青

xiangbaoan 发表于 2021-11-1 08:45

直接复制代码，然后好象不行呢，

3190496160

张青青 发表于 2021-11-1 22:27
大侠您好！已测试，能实现。非常感谢！但如果有新增文件时须关闭目录文件后重新打开，目录里才能显示新增 ...

要学会自己动脑子不是？那你自己在目录工作表华哥按钮，指定一下宏，有新增文件，点击按钮运行一下就可以更新了呀

张青青

3190496160 发表于 2021-11-2 09:58
要学会自己动脑子不是？那你自己在目录工作表华哥按钮，指定一下宏，有新增文件，点击按钮运行一下就可以 ...

指定模块1吗？