Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Userform
BildScreenshot zu Userform Userform-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema TextBox
BildScreenshot zu TextBox TextBox-Seite mit Beispielarbeitsmappe aufrufen

Hyperlink auf Sheet in anderer Datei | Herbers Excel-Forum


Betrifft: Hyperlink auf Sheet in anderer Datei von: Christoph Zach
Geschrieben am: 21.10.2008 08:04:42

Hallo zusammen, mal wieder ein kleines Problem:

Ich lese aus einer Zelle den Text Karteikartenneu\A.xls#'Nachname Vorname Ort'!A4 ein.
Ziel des unten stehenden Codes ist es, im Unterverzeichnis Karteikartenneu die Datei A.xls zu öffnen und das Sheet Nachname Vorname Ort im Vordergrund zu aktivieren.

Set zelle = ActiveCell
link = Cells(zelle.Row, 18).Value

If link <> "" Then
dateiadresse = Left(link, InStr(link, "#") - 1) 'alles was links vom ' steht
kundeadresse = Mid(link, InStr(link, "#") + 1) 'alles was rechts inkl ' steht
ThisWorkbook.FollowHyperlink Address:=dateiadresse, SubAddress:=kundeadresse, NewWindow:=False, AddHistory:=True
Exit Sub
End If

Er öffnet mir zwar die Datei, geht allerdings nichts auf das Sheet. Warum nicht?

Grüße

  

Betrifft: AW: Hyperlink auf Sheet in anderer Datei von: fcs
Geschrieben am: 21.10.2008 10:10:06

Hallo Christoph,

die Verarbeitung der SubAddress unter VBA funktioniert scheinbar nicht genau so wie bei einem manuell eingerichteten Hyperlink. Insbesondere dann, wenn der Tabellenname Sonderzeichen enthält und in Hochkommata ("'") eingefasst ist.
Bei mir unter Excel 2003 wird vom Makro manchmal das korrekte Tabellenblatt angewählt, aber die Zelle nicht selektiert.

Mit folgender Anpassung werden Tabelle und die Zelle gemäß Hyperlink selektiert.

Gruß
Franz

Sub aatest()
  Dim zelle As Range
  Dim dateiadresse As String, kundetabelle As String, link As String, strZelle As String
  
  Set zelle = ActiveCell
  link = Cells(zelle.Row, 18).Value
  
  If link <> "" Then
    dateiadresse = Left(link, InStr(link, "#") - 1) 'alles was links vom ' steht
    'Tabellenname isolieren
    kundetabelle = Mid(link, InStr(link, "#") + 1, InStr(link, "!") - InStr(link, "#") - 1)
    If Left(kundetabelle, 1) = "'" Then
      kundetabelle = Mid(kundetabelle, 2, Len(kundetabelle) - 2) 'Tabellenname
    End If
    strZelle = Mid(link, InStr(link, "!") + 1) 'alles was rechts von ! steht
    ThisWorkbook.FollowHyperlink Address:=dateiadresse, _
        NewWindow:=False, AddHistory:=True
    Worksheets(kundetabelle).Activate
    Range(strZelle).Select
    Exit Sub
  End If

End Sub




  

Betrifft: AW: Hyperlink auf Sheet in anderer Datei von: Christoph Zach
Geschrieben am: 22.10.2008 08:04:44

Hallo, der code funktioniert super. Nur würde ich jetzt noch nach einer Abfrage die geöffnete Datei gerne wieder schließen. In link steht jetzt "A.xls%Nachname Vorname Ort". Das Prozentzeichen trennt Dateiname und Name des Tabellenblatts. Grund ist, dass aus zukünftigen Kundenblättern in meine Masterdatei der link zurückgeschrieben wird (aber die funktion erkämpfe ich mir selber).
verz_karteikarten ist eine globale Variable mit dem String "\Karteikartenneu\".

Und noch was ist mir aufgefallen: Der Befehl Range("A3").Select wird nicht ausgeführt.

Wer kann mir helfen? Vielen Dank schon mal.

Dim zelle As Range
Dim link As String
Dim dateiadresse As String
Dim sheetadresse As String

Set zelle = ActiveCell
link = Cells(zelle.Row, 18).Value

If (link <> "") And (InStr(1, link, "%") <> 0) Then
dateiadresse = Mid(verz_karteikarten, 2) & Left(link, InStr(link, "%") - 1)
sheetadresse = Mid(link, InStr(link, "%") + 1)
ThisWorkbook.FollowHyperlink Address:=dateiadresse, NewWindow:=False, AddHistory:=True
Worksheets(sheetadresse).Activate
Range("A3").Select
n = MsgBox("Richtige Kundenkartei gefunden?", vbYesNo, "Richtiger Kunde?")
If n = vbYes Then Exit Sub
End If

'Ab hier kommt noch weiterer Code, der aber noch nicht angepasst ist!


  

Betrifft: AW: Hyperlink auf Sheet in anderer Datei von: fcs
Geschrieben am: 22.10.2008 10:21:51

Hallo Christoph,

bei der Erstellung von Prozeduren, speziell bei komplexeren, sollte man mit Objekt-Variablen arbeiten.
So kann man nach dem Zuweisen eines Objekts an beliebiger Stelle im Code über die Variablen auf die Objekte zugreifen, um Methoden auf sie anzuwenden oder Eigenschaften abzufragen/zu setzen.

In deiner Prozedur machst du dies unmittelbar nach dem Öffnen der Arbeitsmappe via Hyperlink, da diese dann die aktive Arbeitsmappe ist. Ahnliches gilt auch für Tabellenblätter.

Gruß
Franz

Sub aatest()
  Dim zelle As Range
  Dim link As String
  Dim dateiadresse As String
  Dim sheetadresse As String
  Dim wbAdresse As Workbook, wksAdresse As Worksheet
  Dim n As Long
  Set zelle = ActiveCell
  link = Cells(zelle.Row, 18).Value
  
  If (link <> "") And (InStr(1, link, "%") <> 0) Then
    dateiadresse = Mid(verz_karteikarten, 2) & Left(link, InStr(link, "%") - 1)
    sheetadresse = Mid(link, InStr(link, "%") + 1)
    ThisWorkbook.FollowHyperlink Address:=dateiadresse, NewWindow:=False, AddHistory:=True
    Set wbAdresse = ActiveWorkbook
    Set wksAdresse = wbAdresse.Worksheets(sheetadresse)
    wksAdresse.Activate
    Range("A3").Select
    n = MsgBox("Richtige Kundenkartei gefunden?", vbYesNo, "Richtiger Kunde?")
    If n = vbYes Then Exit Sub
  End If
  
  If Not wbAdresse Is Nothing Then wbAdresse.Close

End Sub




  

Betrifft: AW: Hyperlink auf Sheet in anderer Datei von: Christoph
Geschrieben am: 27.10.2008 10:13:27

Hallo Franz,

ich hätte den Code jetzt soweit fertig. Nur frage ich mich, ob er etwas optimiert werden müsste.
könntest du mir dabei helfen?

Anbei poste ich mal den fertigen, funktionierenden Code.

Das komplette Modul inkl. Dateien möchte ich hier nicht posten, da in den Tabellen vertrauliche Inhalte stehen. Falls es allerdings notwendig ist, sende mir an niitaka82@googlemail.com eine Mail. Ich sende dir dann die Dateien als zip.

Die Fehlerbehandlungsroutine funktioniert zwar, ist jedoch mit goto gelöst. Das mach mir ein bisschen kopfschmerzen. im Teil Direktlink ist das allerdings notwendig, da im Adressblatt eventuell ein Direktlink stehen kann, das sheet aber noch gar nicht existiert.

Und die Suche im Teil Kundenblatt nach Anfangsbuchstabe suchen könnte noch optimiert werden, da bisher nur ein 1:1-Vergleich durchgeführt wird.

Vielen Dank
Christoph

Sub Kundenkarte_oeffnen() 'Kundennummer gehört noch eingefügt
    'Variablendeklaration
    Dim n As Long
    Dim i As Integer
    
    Dim link As String
    Dim dateiadresse As String
    Dim sheetadresse As String
    Dim sheetname As String
    Const trennzeichen As String = "%"
    
    Dim zelle As Range
    Dim wkb_Ziel As Workbook
    Dim wks_Adresse As Worksheet
    Dim wkb_Kundenadressen As Workbook
    Dim wks_Kundenadressen As Worksheet
    Dim tabellenblatt As Worksheet
    
    On Error GoTo fehler_sheet
    
    UserForm4.Hide
    Set wks_Kundenadressen = ActiveWorkbook.ActiveSheet
    Set wkb_Kundenadressen = ActiveWorkbook
    Set zelle = ActiveCell
    
    link = Cells(zelle.Row, 18).Value
    
    'Direkt verlinktes Kundenblatt öffnen
    If (link <> "") And (InStr(1, link, trennzeichen) <> 0) Then
        dateiadresse = Mid(verz_karteikarten, 2) & Left(link, InStr(link, trennzeichen) - 1)
        sheetadresse = Mid(link, InStr(link, trennzeichen) + 1)
        ThisWorkbook.FollowHyperlink Address:=dateiadresse, NewWindow:=False, AddHistory:=True
        Set wkb_Ziel = ActiveWorkbook
        Set wks_Adresse = wkb_Ziel.Worksheets(sheetadresse) 'Fehlerbehandlungsroutine, wenn  _
Sheet nicht existiert
        wks_Adresse.Activate
        Range("A3").Select
        n = MsgBox("Richtige Kundenkartei gefunden?", vbYesNo, "Richtiger Kunde?")
        If n = vbYes Then
            Call beenden
            Set wkb_Ziel = Nothing
            Set wks_Adresse = Nothing
            Exit Sub
        End If
        wkb_Ziel.Close
    End If
   
    'Kundenblatt in Datei mit Anfangsbuchstaben von Nachname suchen
    Set wks_Adresse = Nothing
    dateiadresse = Mid(verz_karteikarten, 2) & Left(nachname, 1) & ".xls"
    ThisWorkbook.FollowHyperlink Address:=dateiadresse, NewWindow:=False, AddHistory:=True
    Set wkb_Ziel = ActiveWorkbook
    For Each wks_Adresse In Worksheets
        If InStr(wks_Adresse.Name, nachname) > 0 Then 'Die Suchfunktion kann man noch  _
optimieren
            wks_Adresse.Activate
            n = MsgBox("Richtige Kundenkartei gefunden?", vbYesNo, "Weitersuchen?")
            If n = vbYes Then
                wks_Kundenadressen.Activate 'Direktlink erstellen
                Call schutz_aus
                Cells(zelle.Row, 18).Value = wkb_Ziel.Name & trennzeichen & wks_Adresse.Name
                Call schutz_ein
                Call beenden
                wks_Adresse.Activate
                Set wkb_Ziel = Nothing
                Set wks_Adresse = Nothing
                Set wkb_Kundenadressen = Nothing
                Set wks_Kundenadressen = Nothing
                Exit Sub
            End If
        End If
    Next wks_Adresse

fehler_sheet:
    'Abfrage ob Kundenkartei angelegt werden soll. Bei Nein beenden und zurück zur Userform
    n = MsgBox("Keine Kundenkartei gefunden. Kunde neu anlegen?", vbYesNo, "Neu Anlegen?")
    If n = vbNo Then
        wkb_Ziel.Close
        wks_Kundenadressen.Activate 'Direktlink erstellen
        Call schutz_aus
        Cells(zelle.Row, 18).Value = ""
        Call schutz_ein
        Set wkb_Ziel = Nothing
        Set wks_Adresse = Nothing
        Set wkb_Kundenadressen = Nothing
        Set wks_Kundenadressen = Nothing
        UserForm4.Show
        Exit Sub
    End If
    
    'Kundenkartei neu anlagen
    wkb_Kundenadressen.Sheets("Nachname Vorname Ort").Copy After:=wkb_Ziel.Sheets(wkb_Ziel. _
Sheets.Count)
    ActiveSheet.Activate
    Set wks_Adresse = ActiveSheet
    sheetname = nachname & " " & vorname & " " & ort
    ActiveSheet.Name = Left(sheetname, 30)
    
    wks_Kundenadressen.Activate 'Direktlink erstellen
    Call schutz_aus
    Cells(zelle.Row, 18).Value = wkb_Ziel.Name & trennzeichen & wks_Adresse.Name
    Call schutz_ein
    Call beenden
    wks_Adresse.Activate
   
    
    Cells(3, 1).Value = vorname & " " & nachname
    
    Range("A1").MergeArea.ClearContents
    Cells(1, 1).Hyperlinks.Add Anchor:=Cells(1, 1), Address:="", SubAddress:="'" & Left( _
nachname, 1) & "'!A1", TextToDisplay:="Zurück zur Namensübersicht " & Left(nachname, 1)
    Range("A1").MergeArea.Font.Bold = True
    Range("A1").MergeArea.Font.Size = 20
    
    'Neues Inhaltsverzeichnis in Datei erstellen
    For Each tabellenblatt In Worksheets
        If InStr(tabellenblatt.Name, Left(nachname, 1)) > 0 Then
            tabellenblatt.Select
            Range("A5:D20").ClearContents
            Range("A5:D20").ClearFormats
            For i = 1 To Worksheets.Count
                Cells(i + 3, 1) = Worksheets(i).Name
                Cells(i + 3, 1).Hyperlinks.Add Anchor:=Cells(i + 3, 1), Address:="", SubAddress: _
="'" & Worksheets(i).Name & "'!A3", TextToDisplay:=Worksheets(i).Name
            Next i
            
            'Inhaltsverzeichnis sortieren einfügen
            Range(Cells(5, 1), Cells(i + 3, 20)).Select
            Selection.Sort Key1:=Range("A4"), Order1:=xlAscending, Header:=xlGuess, OrderCustom: _
=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
            Range("A3").Select
            Range("A3").Select
            Set wkb_Ziel = Nothing
            Set wks_Adresse = Nothing
            Set wkb_Kundenadressen = Nothing
            Set wks_Kundenadressen = Nothing
            Exit Sub
        End If
    Next tabellenblatt
    
End Sub




  

Betrifft: AW: Hyperlink auf Sheet in anderer Datei von: fcs
Geschrieben am: 27.10.2008 14:07:23

Hallo Christoph,

der Code schaut ganz ordentlich aus. An der einen oder anderen Stelle könnte man sicherlich noch "Activate" oder "Selcet"-Anweisungen vermeiden/weglassen.

Für die Fehlerbehandlung hat sich bei mir das folgende Schema bewährt. Dabei wird die Nummer des aufgetretenen Fehlers in einer Select Case - Anweisung abgefragt und entsprechende Aktionen ausgeführt.

Gruß
Franz

Sub aatest()
  Dim abc As Variant
  On Error GoTo FehlerBehandlung
  'Code für normale Bearbeitung
  'Code Teil 1
Resume01: 'Zeile für Rückssprung nach Fehler
  'Code Teil 2

FehlerBehandlung:
  If Err.Number <> 0 Then
    Select Case Err.Number
      Case 70 ' Fehler bei Ordnerzugriff, keine Leseberechtigung
        MsgBox "Fehler Nr. " & Err.Number & vbLf & Err.Description _
          & "Spezieller Hinweis text"
        Resume Next 'Fortsetzung in nächster Zeile in Hauptprozedur
      Case 1234
        MsgBox "Fehler Nr. " & Err.Number & vbLf & Err.Description _
          & "Spezieller Hinweis text"
        Resume Resume01 'Fortsetzung an Zeile in Hauptprozedur
      Case 567
        'Code zur Fehler-Behandlung
        
        'Anschliessend wird Prozedur beendet
      Case Else
        MsgBox "Fehler Nr. " & Err.Number & vbLf & Err.Description
    End Select
  End If
  'Code der auch nach Fehler noch ausgeführt werden soll
  Application.ScreenUpdating = True
End Sub




Beiträge aus den Excel-Beispielen zum Thema "Hyperlink auf Sheet in anderer Datei"