Suche und Kopier bei Klick auf Hyperlink
Chris
eine Frage in Sachen Bei-KLick-Auf-Hyperlink. Unten stehendes Makro bewirkt, dass in Tabellenblatt1 in der Spalte D5-D54 Namenskürzel in Tabellenblatt2 als Hyperlinks umgewandelt und untereinander aufgelistet werden. So wird z. B. die Buchstabenfolge "MKG" als Link in Tabellenblatt 2 angezeigt.
Funktioniert soweit wunderbar.
Nun soll das Makro noch folgendes tun: Bei Klick auf einen der Hyperlinks in Tabellenblatt 2 und dem Wort "OK" und Range G10 (s. unten) soll Excel das entsprechende Kürzel in Tabellenblatt 1 suchen (z.b Klick auf MKG suche "MKG" in Tabelle1) und dann in Tabellenblatt 1:
a) den Inhalt der Zelle RECHTS neben dem Kürzel kopieren. Steht also "MKG" in D5 soll auch E5 kopiert werden. Gleichzeitig soll auch der Inhalt von den ZWEI ZELLEN LINKS neben MKG kopiert werden (hier im Beispiel als C5 und B5).
zur Verdeutlichung, Tabelle zwei sieht so aus (Nachname, Vorname, Kürzel, Sollstunden)
Mustermann / Karl-Gustav / MKG / 12
b) Die kopierten Zellen sollen dann in Tabellenblatt 2 an unterschiedlichen Positionen kopiert werden.
1. Zelle links vom Kürzel (hier beispw. E5) immer in Tabelle2, Range G18
1. Zelle rechts vom Kürzel immer in Tabelle2, Range E18
2. Zelle links vom Kürzel immer in Tabelle1, Range D18
Wichtig ist, dass die Kürzel für Excel variabel bleiben. Also egal, welche Kürzel man eingibt Excel soll das entsprechende Kürzel suchen, und die rechts und links stehendes Zelle(n) an bestimmten Postionen in Tabellenbaltt2 einfügen.
Hat da jemand eine Idee? Bin für Vorschläge dankbar.
Hier das Makro:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Not Intersect(Target.Range, Range("A1:B25")) Is Nothing Then
If UCase(Range("G10")) = "OK" Then
*** HIER MÜSSTE JETZT DAS SUCHE UND KOPIERE MAKRO HIN ***
Else
MsgBox "kein OK!!!", , "Info"
End If
End If
End Sub
Sub HyperlinksAktualisieren()
Dim c As Range
Tabelle2.Range("A1:B25").Hyperlinks.Delete
For Each c In Tabelle2.Range("A1:B25")
With Tabelle1.Range(c.Address)
.Hyperlinks.Add .Cells(1), "", .Parent.Name & "!G10", "OK?", c.Value
End With
Next
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D5:D50")) Is Nothing Then
HyperlinksAktualisieren
End If
If Not Intersect(Target, Range("D5:D50")) Is Nothing And Target.Count = 1 Then
If Target.Value "" Then Target = UCase(Target)
End If
If Not Intersect(Target, Range("B5:C50")) Is Nothing Then
With Application
.EnableEvents = False
Target = .Proper(Target)
.EnableEvents = True
End With
End If
End Sub