Pfad gezielt öffnen

Private Sub Übertrag()
' Nur Codefragment, da nur die gezielte Öffnung eines Pfades ermittelt werden soll
Dim strFile As String, strNewName As String
Dim objWB As Workbook, objWS As Worksheet, objTarget As Worksheet
Dim rng As Range, rngF As Range, rngC As Range
Dim blnOpen As Boolean
Dim lngRow As Long, lngLast As Long, lngN As Long
Dim varResult As Variant
On Error GoTo ErrExit
GMS
strFile = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm")
If strFile = "Falsch" Or strFile = ThisWorkbook.FullName Then GoTo ErrExit
blnOpen = IsOpen(strFile)
If blnOpen Then
Set objWB = Workbooks(Mid(strFile, InStrRev(strFile, "\") + 1))
Else
Set objWB = Workbooks.Open(strFile)
End If
'es folgen noch mehrere Übertragungen, die für die Lösung des neuen Problems nicht relevant  _
sind, 14.02.2010
'usw
'Datei speichern, hier nicht relevant, 14.02.2010
objWB.Close
MsgBox "Fertig"
ErrExit:
With Err
If .Number = 1004 And .Description Like "*schreibgeschützt*" Then
.Clear
Resume Next
End If
If .Number  0 Then MsgBox .Number & vbLf & vbLf & .Description, vbExclamation, "Fehler"
End With
GMS True
Set objWB = Nothing
Set objWS = Nothing
Set rng = Nothing
Set rngF = Nothing
Set rngC = Nothing
End Sub

Private Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long
With Application
.ScreenUpdating = Modus
.EnableEvents = Modus
.DisplayAlerts = Modus
.EnableCancelKey = IIf(Modus, 1, 0)
If Not Modus Then lngCalc = .Calculation
If Modus And lngCalc = 0 Then lngCalc = -4105
.Calculation = IIf(Modus, lngCalc, -4135)
.Cursor = IIf(Modus, -4143, 2)
End With
End Sub

Private Function IsOpen(ByVal WBFullName As String) As Boolean
Dim objWB As Workbook
For Each objWB In Application.Workbooks
If objWB.FullName = WBFullName Then
IsOpen = True
Exit For
End If
Next
End Function