[已解决]双击单元格打开同文件夹内相同名称的文件

xyh2732

新建文件夹 (2).rar (97.86 KB, 下载次数: 25)

2012-8-17 19:04 上传

点击文件名下载附件 请问如何可以双击A列单元格打开同意文件夹上的同名文件.             比如双击A2系统自动打开同意文件夹内同名字的文件3333.XLS

最佳答案

月排行榜 / 总排行榜

柳如烟

2012-8-17 21:58

1. 
   
2. Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
   
3.     (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
   
4.     ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long   
   
5. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
6.     Dim rng
   
7.     Set rng = Range("a2:a" & Range("a65536").End(3).Row)
   
8.     If Not Application.Intersect(Target, rng) Is Nothing Then
   
9.         If Dir(ThisWorkbook.Path & "" & Target.Value) = "" Then
   
10.             MsgBox "该文件夹下没有此文件!请检查" & Chr(10) & "文件名称是否正确!", vbCritical, "错误提示"
    
11.             Exit Sub
    
12.         End If
    
13.         If Target.Value = ThisWorkbook.Name Then
    
14.             MsgBox "当前文件已经打开!", vbExclamation, " 提示"
    
15.             Cancel = True
    
16.             Exit Sub
    
17.         End If
    
18.         On Error Resume Next
    
19.         If InStr(UCase(Target.Value), ".XLS") <> 0 Then
    
20.             Workbooks.Open ThisWorkbook.Path & "" & Target.Value
    
21.         Else
    
22.             ShellExecute 0, "open", Target.Value, "", ThisWorkbook.Path & "", 5
    
23.         End If
    
24.         Cancel = True
    
25.     End If
    
26. End Sub
    
27. 
    

复制代码

代码在汇总表（在我电脑上打开EXCEL文件总是有点问题，所以加上了workbooks.open方法）

跳转到最佳答案楼层

hoogle

1. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
2. If Target.Row > 1 And Target.Row < 20 And Target.Column = 1 Then
   
3. Workbooks.Open (ThisWorkbook.Path & "" & Target.Value)
   
4. End If
   
5. End Sub

复制代码

在工作表“规律表”里加入以上事件代码，可以打开EXCEL文件，打开图片代码我还不会写。

zjcat35

1. Sub Macro1()
   
2.     Dim i%
   
3.     With Sheet1
   
4.         For i = 2 To Cells(Rows.Count, 1).End(3).Row
   
5.             .Cells(i, 1).Hyperlinks.Delete
   
6.             .Hyperlinks.Add Anchor:=Cells(i, 1), Address:=ThisWorkbook.Path & "/" & Cells(i, 1).Value, _
   
7.                             TextToDisplay:=Cells(i, 1).Value
   
8.         Next i
   
9.     End With
   
10. End Sub

复制代码

柳如烟

1. 
   
2. Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
   
3.     (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
   
4.     ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long   
   
5. Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
6.     Dim rng
   
7.     Set rng = Range("a2:a" & Range("a65536").End(3).Row)
   
8.     If Not Application.Intersect(Target, rng) Is Nothing Then
   
9.         If Dir(ThisWorkbook.Path & "" & Target.Value) = "" Then
   
10.             MsgBox "该文件夹下没有此文件!请检查" & Chr(10) & "文件名称是否正确!", vbCritical, "错误提示"
    
11.             Exit Sub
    
12.         End If
    
13.         If Target.Value = ThisWorkbook.Name Then
    
14.             MsgBox "当前文件已经打开!", vbExclamation, " 提示"
    
15.             Cancel = True
    
16.             Exit Sub
    
17.         End If
    
18.         On Error Resume Next
    
19.         If InStr(UCase(Target.Value), ".XLS") <> 0 Then
    
20.             Workbooks.Open ThisWorkbook.Path & "" & Target.Value
    
21.         Else
    
22.             ShellExecute 0, "open", Target.Value, "", ThisWorkbook.Path & "", 5
    
23.         End If
    
24.         Cancel = True
    
25.     End If
    
26. End Sub
    
27. 
    

复制代码

代码在汇总表（在我电脑上打开EXCEL文件总是有点问题，所以加上了workbooks.open方法）

xyh2732

非常感谢各位的帮忙！谢谢了！