| |
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet, mozi As Variant, zumen As Variant
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)
If Target <> ws3.Range(Target.Address) Then Exit Sub
If Target.Column = 1 Then Exit Sub
If Target.Column > 4 Then Exit Sub
If Target.Row < 3 Then Exit Sub
If Target = "" Then Exit Sub
If Target.Column = 2 Or Target.Column = 4 Then
Select Case Left(Target, 1)
Case "J"
mozi = "\FJ\" & Target
Case "M"
mozi = "\FM\" & Target
Case "P"
mozi = "\FP\" & Target
Case Else
mozi = "\FX\" & Target
End Select
zumen = ws2.Range("A1") & "DB" & mozi & "\" & Target & ".pdf"
If Dir(zumen) <> "" Then
If MsgBox("組立図面を見ますか？", vbQuestion + vbYesNo) = vbYes Then
ws2.Hyperlinks.Add Anchor:=ws2.Range("AA10"), Address:=zumen
ws2.Range("AA10").Hyperlinks(1).Follow
ws2.Range("AA10").Hyperlinks(1).Delete
End If
End If
zumen = ws2.Range("A1") & "DB" & mozi & "\来歴書DB.xls"
If Dir(zumen) <> "" Then
If MsgBox("来歴書を見ますか？", vbQuestion + vbYesNo) = vbYes Then
ws2.Range("A12") = ws2.Range("A1") & "DB" & mozi & "\"
ws2.Range("A13") = zumen
If Dir(ws2.Range("A1") & "Prg\来歴書.xls") = "" Then
MsgBox ws2.Range("A1") & "Prg\来歴書.xls が見当たりません。大至急管理者に連絡して下さい。"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
Application.EnableEvents = False
Application.ScreenUpdating = False
FileCopy ws2.Range("A1") & "Prg\来歴書.xls", "C:\Fistemp\raireki.xls"
Workbooks.Open "C:\Fistemp\raireki.xls"
ws2.Range("A:A").Copy Workbooks("raireki.xls").Worksheets(2).Range("A:A")
Workbooks("raireki.xls").Worksheets(2).Range("A112") = "oshigoto"
Workbooks("raireki.xls").Close savechanges:=True
Application.ScreenUpdating = True
Application.EnableEvents = True
Workbooks.Open "C:\Fistemp\raireki.xls"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
Else
MsgBox zumen & "が見当たりません。大至急管理者に連絡して下さい。"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
If ws2.Range("A5") = "設計部" Then
If MsgBox("PDF図面フォルダを開きますか？", vbQuestion + vbYesNo) = vbYes Then
zumen = ws2.Range("A1") & "DB" & mozi
If Dir(zumen & "\") = "" Then
MsgBox zumen & "フォルダが見当たりません。大至急管理者に連絡して下さい。"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
Shell "C:\WINDOWS\explorer.exe " & zumen, vbNormalFocus
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
End If
If Dir("C:\WINDOWS\explorer.exe") <> "" Then
If MsgBox("資料フォルダを開きますか？", vbQuestion + vbYesNo) = vbYes Then
zumen = ws2.Range("A2") & "図面" & mozi
If Dir(zumen & "\") = "" Then
MsgBox zumen & "フォルダが見当たりません。大至急管理者に連絡して下さい。"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
Shell "C:\WINDOWS\explorer.exe " & zumen, vbNormalFocus
End If
End If
ElseIf Target.Column = 3 Then
zumen = ws2.Range("A1") & "手配書\" & Target & ".pdf"
If Dir(zumen) <> "" Then
If MsgBox("手配書を見ますか?", vbQuestion + vbYesNo) = vbYes Then
ws2.Hyperlinks.Add Anchor:=ws2.Range("AA10"), Address:=zumen
ws2.Range("AA10").Hyperlinks(1).Follow
ws2.Range("AA10").Hyperlinks(1).Delete
End If
End If
If Dir("C:\WINDOWS\explorer.exe") <> "" Then
If MsgBox("手配書フォルダを開きますか？", vbQuestion + vbYesNo) = vbYes Then
zumen = ws2.Range("A1") & "手配書\" & Target
If Dir(zumen & "\") = "" Then
MsgBox zumen & "手配書フォルダが見当たりません。大至急営業部に連絡して下さい。"
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
End If
Shell "C:\WINDOWS\explorer.exe " & zumen, vbNormalFocus
End If
End If
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
ど素人が作ったものなので、醜くてすいません。
図面番号が書かれたセルをダブルクリックすると、関連するPDF図面やフォルダを開いたり、別のブックに移動したりします。
2003で作成し、問題なく動いていました。
最近OSが7の32bit版 Excelは2010になりました。
互換モードで動かしています。
すべてのMsgBoxにNoと答えると、
「Excelは動作を停止しました。」
「問題が発生したため、・・・」
で、強制終了してしまいます。
End Sub のひとつ前にMsgBoxを入れると、そのメッセージは表示されます。
全く解決方法が見つかりません。
御教授よろしくお願いいたします。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
