VBA Werte als Zellbezug und Hyperlink übertragen

Hallo zusammen.
Ich benütze nachfolgendes Macro, um aus einem Rezeptblatt bestimmte Werte wie den Namen des jeweiligen Rezeptes, den Autor, das Erstellungsdatum und den kalkulierten Preis an eine Rezeptliste ("Inhaltsverzeichnis") zu übergeben. Das Makro erkennt jeweils die letzte Zeile im Inhaltsverzeichnis und schreibt in die entsprechend nachfolgende freie Zeile. Es wird in die Spalten A bis E geschrieben. Das funktioniert so weit ausgezeichnet, aber:
Der Rezeptname soll nicht als blosser Zellwert (String) übergeben werden, sondern als Hyperlink, so das vom Blatt "Inhaltsverzeichnis" beim Anklicken des Rezeptnamens wieder auf das entsprechende Rezeptblatt gesprungen wird. Der Rezeptname wird in Zelle D1 des Rezeptblattes aus dem aus dem Blattname vom Register eingetragen mit der Formel: =TEIL(ZELLE("Dateiname";D1);FINDEN("]";ZELLE("Dateiname";D1))+1;31).
Der Preis soll zweimal übergeben werden. Der Preis wird aus Zelle E40 des Rezeptblattes bezogen. In Spalte B (Kartenpreis) des Blattes "Inhaltsverzeichnis" soll der Preis als Wert (Double) übergeben werden, was auch super funktioniert. In Spalte C (aktueller Preis) soll statt des Wertes ein Zellbezug zu E40 im Rezeptplatt eingefügt werden. Hintergrund: Sollte sich der kalkulierte Preis des Rezeptes durch beispielsweise geänderte Zutatenpreise ändern, soll im Blatt "Inhaltsverzeichnis" der Preisunterschied zum originalen Preis sichtbar gemacht werden (das wird dann mit bedingter Formatierung hervorgehoben).

Sub RezeptKatalog() 'speichert die wichtigsten Daten im Blatt "Inhaltsverzeichnis"
Const dieListe As String = "Inhaltsverzeichnis" 'deklariert das Zielblatt
Dim SuZ1 As Long
Dim Rezept As String
Dim KartPreis As Double
Dim aktPreis As Double
Dim Autor As String
Dim RezDat As Date
Dim objWS As Worksheet
ActiveSheet.Select
Set objWS = ActiveSheet
Rezept = Range("D1").Value
KartPreis = Range("E40").Value
aktPreis = Range("E40").Value
Autor = Range("B6").Value
RezDat = Range("B5").Value
Sheets("Inhaltsverzeichnis").Activate
Call SchutzAus
SuZ1 = 3
While Not (IsEmpty(Sheets(dieListe).Cells(SuZ1, 1)))
SuZ1 = SuZ1 + 1
Wend
Sheets(dieListe).Cells(SuZ1, 1).Formula = Rezept
Sheets(dieListe).Cells(SuZ1, 2).Formula = KartPreis
Sheets(dieListe).Cells(SuZ1, 3).Formula = "=" & objWS.Name & "!E40"
Sheets(dieListe).Cells(SuZ1, 3).Formula = aktPreis
Sheets(dieListe).Cells(SuZ1, 4).Formula = Autor
Sheets(dieListe).Cells(SuZ1, 5).Formula = RezDat
Sheets(dieListe).Hyperlinks.Add Anchor:=Cells(SuZ1, 1), Address:="", SubAddress:=objWS.Name & "! _
$A$18", TextToDisplay:=CStr(objWS.Name)
Call SchutzEin
End Sub

Ich wäre froh, wenn ihr eine Idee dazu hättet :-)
Hier der Link zur Musterdatei: https://www.dropbox.com/s/sk24es44qsd40dq/InventarRezeptkalkulatorVersion6.xlsm?dl=0
Grüssle und merci im Voraus.
Ringo

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub RezeptKatalog() 'speichert die wichtigsten Daten im Blatt "Inhaltsverzeichnis" Const dieListe As String = "Inhaltsverzeichnis" 'deklariert das Zielblatt Dim SuZ1 As Long Dim Rezept As String Dim KartPreis As Double Dim aktPreis As Double Dim Autor As String Dim RezDat As Date Dim objWS As Worksheet ActiveSheet.Select Set objWS = ActiveSheet With objWS Rezept = .Range("D1").Value KartPreis = .Range("E40").Value aktPreis = .Range("E40").Value Autor = .Range("B6").Value RezDat = .Range("B5").Value End With With Sheets(dieListe) 'Sheets("Inhaltsverzeichnis") .Activate Call SchutzAus SuZ1 = 3 While Not (IsEmpty(.Cells(SuZ1, 1))) SuZ1 = SuZ1 + 1 Wend .Cells(SuZ1, 1).Formula = Rezept .Cells(SuZ1, 2).Formula = KartPreis .Cells(SuZ1, 3).Formula = "='" & objWS.Name & "'!E40" ' .Cells(SuZ1, 3).Formula = aktPreis .Cells(SuZ1, 4).Formula = Autor .Cells(SuZ1, 5).Formula = RezDat .Hyperlinks.Add Anchor:=.Cells(SuZ1, 1), Address:="", _ SubAddress:="'" & objWS.Name & "'!A18", _ TextToDisplay:=CStr(objWS.Name) Call SchutzEin End With End Sub

Hallo Franz :-)
Merci zuerst für Deine schnelle Antwort!
Hier mal der Link nach Dropbox, damit Du Dir das mal anschauen kannst. https://www.dropbox.com/s/f87duaraoh6dels/InventarRezeptkalkulatorVersion7.xlsm?dl=0
Das mit den Hochkommas ist ein guter Tipp, in meiner Version funktioniert nämlich genau das nicht. Deswegen habe ich sogar das Blatt "LeerRezept" extra so umbenannt (zuvor "Leer-Rezept".
Ich musste auch extra Code einfügen, damit für den Hyperlink nicht die Standardformatierung (Arial, 12) verwendet wird, das funktioniert auch ganz gut. Was die Möglichkeit betrifft, Leerzeichen und Sonderzeichen beim Blattnahmen zu benützen, habe ich Deinen Code probiert, aber entweder was falsch gemacht oder es funktioniert nicht vollständig. Bei mir ausgeführt dauert das Blattschutz aufheben unnatürlich lange (zapped sich durch alle Blätter, tut es sonst nicht) und es öffnet sich dann ein Fenster, wo man das Ziel für den Blattnamen angeben soll, obwohl das ja aus dem Register des Ursprungsblattes festgelegt ist. Der Zellbezug in Spalte C funktioniert dann auch nicht, wird stattdessen in den Einstellungen zum Hyperlink mit Hochkommas dargestellt. und in der Spalte C wird #BEZUG! angezeigt.
Der Code in der Mustermappe (siehe Link) funktioniert dahingehend einwandfrei, ausser das Sonderzeichen und Leerzeichen nicht benützt werden können. Wenn Du das hinbekämst, wäre das SUPER :-))))
Vielen Dank im Voraus Franz :-)
Ringo

Sub 'Abbruch der Aktion End If Sub RezeptDa() 'prueft, ob der Blattname bereits existiert Dim Sh As Worksheet Dim BlattName As String BlattName = Left([A2:A5000], 30) 'prueft, ob das Rezept bereits im Blatt " _ Inhaltsverzeichnis" existiert For Each Sh In Worksheets 'alle Blaetter (hier soll statt allen Blättern nur das Blatt " _ inhaltsverzeichnis" durchsucht werden. If InStr(Sh.Name, BlattName) > 0 Then 'wenn der Name da ist, dann Abbruch = True 'Abbruch End If Next Sh End Sub Wie müsste das dann aussehen? Vielen lieben Dank Franz! :-) Gruss. Ringo

Sub aatest() If fncRezept_inIV(strRezept:=ActiveSheet.Name) = True Then Beep MsgBox "Bitte anderes Rezept waehlen oder abbrechen!", vbCritical, _ "Dieses Rezept existiert bereits im Inhaltsverzeichnis!" Exit Sub End If End Sub Public Function fncRezept_inIV(strRezept As String) As Boolean Dim wksIV As Worksheet Dim Zelle As Range fncRezept_inIV = False Set wksIV = ActiveWorkbook.Worksheets("Inhaltsverzeichnis") 'Ausnahmen bei Blattnamen prüfen Select Case strRezept Case "", "Inhaltsverzeichnis", "Warenkorb leer", "Stammdaten", _ "LeerRezept", "Inventar", "InvetarDruckSelect" MsgBox "Das Blatt """ & strRezept & """ darf nicht ins " _ & "Inhaltsverzeichnis übernommen werden" fncRezept_inIV = True Exit Function End Select 'Zellinhalte in A2 bis letzte Zelle in Spalte A mit Rezeptname vergleichen With wksIV For Each Zelle In .Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp)) If UCase(Zelle.Text) = UCase(strRezept) Then fncRezept_inIV = True Exit For End If Next Zelle End With End Function

Sub RezeptKatalog() 'uebertraegt den Rezeptname, den originalen Kartenpreis bei _ Rezepterstellung, einen Zellbezug zum allfaellig geaenderten Kartenpreis, 'den Autor und das Datum in das Blatt " _ Inhaltsverzeichnis" in die Spalten A bis E Const dieListe As String = "Inhaltsverzeichnis" 'deklariert das Zielblatt

Beliebteste Forumthreads (12 Monate)

VBA Werte als Zellbezug und Hyperlink übertragen

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Werte als Zellbezug und Hyperlink übertragen

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread