Eben soviele Links :-(
Vielelicht kannst Du mir helfen.
TF
''Die Struktur in diesem Beispiel ist so:
''-----------------------------------------------------------------
''Nr|Thema|Untertitel|Autor|Rubrik|Jahr|Heft|Seite
''-----------------------------------------------------------------
''Die Adressen der Links sind in einem Blatt namens "Links",
''ab A1 lückenlos hinterlegt. Der Code prüft, ob die Anzahl
''der Links mindestens so groß ist, wie die ermittelte Anzahl
''von Kombinationen. Ist das nicht so, gibts eine Meldung.
''Der Code muss in dem Blatt ausgeführt werden, in dem die
''Hyperlinks erstellt werden sollen.
Option Explicit
Option Base 1
Dim arrS() As Long
Dim arrZ() As Long
Dim arrLink() As String
Sub Hyperlink()
Dim z As Long, lZ As Long, x As Long
Dim lZLinks As Long
Application.ScreenUpdating = False
''Sortieren unbedingt erforderlich
Columns("A:I").Sort Key1:=Range("F2"), Order1:=xlAscending, Key2:=Range("H2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:= _
False, Orientation:=xlTopToBottom
lZ = [f65536].End(xlUp).Row
lZLinks = Sheets("Links").[a65536].End(xlUp).Row
ReDim arrS(2 To lZ)
For z = 2 To lZ
arrS(z) = CLng(Cells(z, 6) & Cells(z, 7))
Next
ReDim arrZ(2 To lZ)
x = 1
arrZ(2) = 1
For z = 3 To lZ
If arrS(z) = arrS(z - 1) Then
arrZ(z) = x
Else
x = x + 1
arrZ(z) = x
End If
Next
If lZLinks < WorksheetFunction.Max(arrZ) Then
MsgBox "Die Anzahl der Linkadressen ist kleiner als die " & Chr(10) & _
"Anzahl vorhandener Kombinationen!", 64, "gebe bekannt..."
Call reset
Exit Sub
End If
ReDim arrLink(2 To lZ)
For z = 2 To lZ
arrLink(z) = Sheets("Links").Cells(arrZ(z), 1)
With ActiveSheet
.Hyperlinks.Add .Cells(z, 6), arrLink(z)
End With
Next
''Ggf. wieder alte Sortierung wiederherstellen
Columns("A:H").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Call reset
End Sub
Sub reset()
Erase arrS
Erase arrZ
Erase arrLink
Application.ScreenUpdating = True
End Sub
Falls du Links wieder entfernen willst:
Sub Hyperlinks_weg()
Dim H As Hyperlink
For Each H In ActiveSheet.Hyperlinks
On Error Resume Next
H.Delete
Next
End Sub
https://www.herber.de/forum/messages/139214.html
Gruß Klaus
einen verbesserten Code findest du hier:
https://www.herber.de/forum/messages/139568.html
Gruß Klaus
super, vielen Dank für Deine Hilfe. Wo kann ich ändern, daß der Hyperlink
a) nur in Spalte 5
b) in der ganzen Zeile
erscheint??
Eine kurze Erklärung bitte.
Vielen Dank nochals.
TF
ich habe den Code ein wenig umgestrickt, so dass du selber entscheiden
kannst,
welche Zellen in einer Zeile verknüpft werden. Du musst im Code jetzt nur
noch den Bereich angeben,
der verknüpft werden soll und zwar mit den Konstanten ErsteSpalteHyperlink
und LetzteSpalteHyperlink
Hier der geänderte Code:
Beispiele:
1) Die ganze Zeile verknüpfen:
ErsteSpalteHyperlink = 1
LetzteSpalteHyperlink = 7
2) Nur Zelle 5 verknüpfen:
ErsteSpalteHyperlink = 5
LetzteSpalteHyperlink = 5
3) Zellen 3 bis 6 verknüpfen:
ErsteSpalteHyperlink = 3
LetzteSpalteHyperlink = 6
ACHTUNG: Wenn die Verknüpfungen mit diesem Code wieder aufgehoben werden
sollen,
so müssen die Konstanten auf denselben Werten stehen wie beim Verknüpfen,
weil sonst nciht
alle oder zu viele Verknüpfungen entfernt werden !
Am Besten eine Eintellung festlegen und dann so belassen !
Gruß Klaus