AW: Probleme bei hyperlink eintragung
Steffen
hi,
habe mal einw enigmehr code reingestellt. S wird am anfang auf 1 und t auf 0 gesetzt. werden dann ja hoch gezählt.
hoffentlich blickt ihr da durch
Sub SucheNachNeuAngelegtemSuchkatalogblatt()
Dim SuchKatalogblattName As String
Dim objBlatt As Worksheet
Dim objSuchKatalogblatt As Worksheet
Dim objZelle As Range
Dim objZeile As Range
Dim strErsteFundstelle As String
Dim intButton As Integer
Dim objForm As UserForm
Dim strFundstelle As String
Dim zeile As Variant
Dim Erste As String
Dim auf_dopplung_zu_überprüfende_nummer As String
Dim nummer As String
Dim aRow As Integer
Dim bRow As Integer
Dim j As Integer
Dim x As Integer
Dim S As Integer
Dim T As Integer
Dim Row As Integer
S = 1
If neuanlegenmitneuemnamen = "1" Then
ZuSuchenderBegriff = alterSuchbegriff
End If
'Hier wird nach dem eingegebenen Suchbegriff gesucht
'Es wird NICHT auf Groß- oder Kleinschreibung geachtet
If GroßKleinschreibungNichtBeachten = 1 Then
'Alle Blätter durchlaufen
For Each objBlatt In ActiveWorkbook.Worksheets
'Wenn der Tabellenblattname nicht "Übersicht" ist....
If objBlatt.Name <> "Übersicht" And objBlatt.Name <> "Statistik" Then
If Left(objBlatt.Name, 5) <> "Such_" Then
If Alles = 1 Then
With objBlatt.UsedRange
If Wortteile = 1 Then
Set objZelle = .Find(What:=Trim(ZuSuchenderBegriff), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
End If
If GanzeWörter = 1 Then
Set objZelle = .Find(What:=Trim(ZuSuchenderBegriff), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
End If
If Not objZelle Is Nothing Then
Erste = objZelle.Address
T = 0
Do
strFundstelle = objBlatt.Name & "!" & objZelle.Address
'Wenn der Zusuchende Begriff gefunden wurde, wird die Tabelle, in der der Treffer gelandet
'wurde geöffnet..., wenn bei der Eingabe des Begriffes gewählt wurde, dass die Suche nach jedem Treffer
'unterbrochen werden soll.
If DurchgehendeSuche = 0 Then
If Left(objZelle.Value, 5) <> "Such_" Then
'Blatt mit Fundstelle aktivieren
objBlatt.Activate
'Fundstelle markieren
objZelle.Select
'Anwender fragen, ob Suche fortgesetzt werden soll
intButton = MsgBox("Weiter suchen?", vbQuestion + vbYesNo, APP_NAME)
'Wenn Antwort 'NEIN' lautet, dann...
If intButton <> vbYes Then
'Fragen, ob das Suchkatalogblatt geöffnet werden soll
intButton = MsgBox("Das Suchkatalogblatt öffnen?", vbQuestion + vbYesNo, APP_NAME)
'Wenn die Antwort 'NEIN' lautet, dann...
If intButton <> vbYes Then
'Infofenster mit "Suche beendet!" öffnen und...
MsgBox "Suche beendet!", vbInformation, APP_NAME
'...Makro beenden
Exit Sub
Else
'Suchkatalogblatt aktivieren
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
'... Makro beenden
Exit Sub
End If
End If
'End If
'Hier werden die Treffer Daten aus dem Tabellenblatt, in dem der Treffer war in
'das Suchkatalogblatt übertragen
Application.ScreenUpdating = False
'Blatt mit Fundstelle aktivieren
objBlatt.Activate
'Nun wird in das "Treffer-Tabellenblatt" ein Hyperlink auf das
'Suchtabellenblatt gesetzt
Do
If T = 0 Then
If Cells(S, 6) = "" Then
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(S, 6), Address:="", SubAddress:="'" & ZuSuchenderBegriffSuchkatalogblattName & "'!A1", TextToDisplay:=ZuSuchenderBegriffSuchkatalogblattName
T = T + 1
Exit Do
Else
S = S + 1
ActiveSheet.Hyperlinks.Add Anchor:=.Cells(S, 6), Address:="", SubAddress:="'" & ZuSuchenderBegriffSuchkatalogblattName & "'!A1", TextToDisplay:=ZuSuchenderBegriffSuchkatalogblattName
T = T + 1
End If
Else
Exit Do
End If
Loop While Cells(S, 6) <> ""
'Die Zelle im Katalogblatt mit der CD-Nummer markieren und kopieren
Cells(1, 3).Select
Cells(1, 3).Copy
'Das Suchkatalogblatt öffnen und die CD-Nummer-Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
'Wenn die nächste Zeile leer ist
'Daten in Suchkatalogblatt eintragen
zeile = Worksheets(ZuSuchenderBegriffSuchkatalogblattName).Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(zeile, 1).PasteSpecial
'Hier wird in das Suchkatalogblatt ein Hyperlink auf das
'Trefferblatt gesetzt
With Sheets(ZuSuchenderBegriffSuchkatalogblattName)
.Hyperlinks.Add Anchor:=.Cells(zeile, 6), Address:="", SubAddress:="'" & objBlatt.Name & "'!A1", TextToDisplay:=objBlatt.Name
End With
'Blatt mit Fundstelle aktivieren
objBlatt.Activate
'Die Zelle im Katalogblatt mit der CD-Seite markieren und kopieren
Cells(2, 3).Select
Cells(2, 3).Copy
'Das Suchkatalogblatt öffnen und die CD-Nummer-Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
Cells(zeile, 2).PasteSpecial
'Blatt mit Fundstelle aktivieren
objBlatt.Activate
'Die Zelle im Katalogblatt mit dem Künstler markieren und kopieren
Cells(3, 3).Select
Cells(3, 3).Copy
'Das Suchkatalogblatt öffnen und die Künstler-Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
Cells(zeile, 3).PasteSpecial
'Blatt mit Fundstelle aktivieren
objBlatt.Activate
'Die Zelle im Katalogblatt mit dem Album markieren und kopieren
Cells(4, 3).Select
Cells(4, 3).Copy
'Das Suchkatalogblatt öffnen und die Album-Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
Cells(zeile, 4).PasteSpecial
'Die Zelle, in der der Treffer gelandet wurde, wird nun in das
'Suchkatalogblattt eingetragen
'Blatt mit Fundstelle aktivieren
objBlatt.Activate
'Fundstelle markieren
objZelle.Select
With Selection
.Copy
End With
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
Cells(zeile, 6).PasteSpecial
'In das Suchkatalogblatt wird nun eingetragen, in welcher Spalte das
'gesuchte Wort gefunden wurde, ob es z.B ein Titel ist
'Wenn der gesuchte Begriff in "Künstler" war...
If objZelle.Address = "$C$3" Then
'Das Suchkatalogblatt öffnen und die Album-Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
If Cells(zeile, 5).Value = "" Then
Cells(zeile, 5).Value = "Künstler"
End If
End If
'Wenn der gesuchte Begriff in "Album" war...
If objZelle.Address = "$C$4" Then
'Das Suchkatalogblatt öffnen und die Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
If Cells(zeile, 5).Value = "" Then
Cells(zeile, 5).Value = "Album"
End If
End If
Do
'Wenn der gesuchte Begriff in "Album" war...
If objZelle.Address <> "$C$4" & Row Then
Row = Row + 1
Else
Exit Do
End If
Loop While Row < 30
'Das Suchkatalogblatt öffnen und die Daten eintragen
Sheets(ZuSuchenderBegriffSuchkatalogblattName).Select
If Cells(zeile, 5).Value = "" Then
Cells(zeile, 5).Value = "Titel"
End If
End If
Application.ScreenUpdating = True
'Es wird nach dem nächsten Treffer gesucht
End If
End Sub