AW: Hyperlink auf Sheet in anderer Datei
27.10.2008 10:13:27
Christoph
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