Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1280to1284
1280to1284
Aktuelles Verzeichnis
Verzeichnis Übersicht
Verzeichnis Übersicht
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Formular optional Button einmal klicken

Forumthread: Formular optional Button einmal klicken

Formular optional Button einmal klicken
21.10.2012 16:46:50
Dieter(Drummer)
Hi VBA Spezailisten,
ich möchte auf dem aktiven TabBlatt einen Formular Button NUR einmal anklicken dürfen. Wichtig ist, wurde er schon einmal angelickt worden, soll eine Option kommen "Nochmal KLICKEN?, mit "Ja/Nein" Möglichkeit. Es sind viele Buttons auf dem Tab.Blatt und kann das dann für alle vorhandenen Buttons gelten? Wenn nicht, würde ich es jedem Button zuweisen.
Danke für Hilfe eine Lösung.
Gruß, Dieter(Drummer)

Anzeige

31
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Formular optional Button einmal klicken
21.10.2012 16:59:05
Beverly
Hi Dieter,
das ist für mich ein Widerspruch: der Buttin darf nur einmal angeklickt werden - es soll eine Abfrage kommen ob noch einmal geklickt werden darf.
Schreibe bei Klick auf den Button etwas in eine Zelle (z.B. die Zelle auf der der Button liegt). Prüfe dabei, ob in der Zelle schon etwas steht - wenn ja, dann die Klick-Prozedur verlassen.
Damit du nicht jedem Button ein eigenes Marko zuweisen musst, kannst du die Funktionalität des Application.Caller und die Zellposition des Schalters verwenden.

Anzeige
AW: Formular optional Button einmal klicken
21.10.2012 17:12:07
Dieter(Drummer)
Hi Karin,
Danke für schnelle Rückmeldung. Der Sinn liegt darin, dass bei ersten Buttonklick ein Pfeil (Linie) gezeichnet wird. Würde ich nochmal auf den Button klicken, würde der Pfeil (Linie) ein 2. mal eingefügt und ist dann doppelt. Dies will ich vermeiden, da das Dupliktat nicht so einfach zu erkennen ist.
Ich kann auch die Datei senden, wenn es dann verständlicher wird. Wenn nötig, bitte kurze Info.
Gruß
Dieter(Drummer)

Anzeige
AW: Hier mal meine Datei ...
21.10.2012 17:35:58
hary
Moin Dieter
Hab hier kein Excel.
Als Makro: 
Sub ZahlunterButton()
Dim varCaller, objZelle As Range
varCaller = Application.Caller 'Name des aufrufenden Buttons
Set objZelle = ActiveSheet.Shapes(varCaller).TopLeftCell
'Zahl unter Buttonzelle eintragen
objZelle.Value = 1
End Sub

Aufruf durch den Button(Zuweisen). Alle Buttons nur das eine Makro
Im Makro kannst du dann die 1 auswerten.
gruss hary

Anzeige
AW: Danke Hary ...
21.10.2012 18:07:25
Dieter(Drummer)
... schön von dir zu hören und Danke für Makro. Rufe das Makro über Call ... am Anfang des Button-Makros auf und es wird z.B. in Zelle eine 1 eingetragen. Wie ich jetzt die eins auswerten kann, dass das der Buttomn nicht noch einmal eien Linie erzeigt, weiß ich nicht. Wenn ich den Button "Alle Pfeile löschen" klicke, müssen auch alle Buttons weider frei sei. Warcheinlich müsste ich dann dei 1nsen löschen.
Gruß
Dieter(Drummer)

Anzeige
AW: Wohl mit "If yx Zelle = 1 then Extit sub ...
21.10.2012 18:09:41
Dieter(Drummer)
... oder so ähnlich. Wie mach ich das dann.
Gruß
Dieter(Drummer)

AW: Hier mal meine Datei ...
21.10.2012 18:41:30
Beverly
Hi Dieter,
als Prüfeigenschaft hast du doch die Schriftfarbenänderung.
Du könntest allen Buttons diesen gemeinsamen Code zuweisen - ich habe ihn allerdings erst für 3 Buttons geschrieben, musst du entsprechend erweitern.
Sub PfeileEinfuegen()
With ActiveSheet.Shapes(ActiveSheet.Application.Caller)
Select Case ActiveSheet.Shapes(ActiveSheet.Application.Caller).DrawingObject.Caption
Case "1 > 2"
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(56.25, 132.75, 56.25, 183.75)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
End If
Case "1 > 4"
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(66.75, 127.5, 156.75, 189#)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
End If
Case "1 > 5"
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(69#, 195.75, 155.25, 195.75)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
End If
End Select
End With
End Sub
Zum Löschen der Pfeile und Zurücksetzen der Schriftfarbe kannst du diesen angepassten Code verwenden:
Sub Pfeile_Linien_Loeschen()
Dim Shl As Object
For Each Shl In ActiveSheet.Shapes
If Shl.Type = 9 Then
Shl.Delete
ElseIf InStr(Shl.DrawingObject.Caption, " > ") > 0 Then
Shl.DrawingObject.Font.ColorIndex = 5
End If
Next
End Sub

Anzeige
AW: Danke dir Karin ....
21.10.2012 18:49:11
Dieter(Drummer)
... für deine Lösung. Ich hatte auch schon eine:

Call ZahlunterButton 'Von Hary
If Range("F6").Value = "" Then 'Hier wird in F6 eine 1 durch den Caller gesetzt
End If
Diese funktonierte auch. Deine Lösung baue ich mal komplett ein und melde dann.
Nochmal herlzichen Dank und Gruß
Dieter(Drummer)

Anzeige
AW: Prima Karin ... aber ...
21.10.2012 19:04:13
Dieter(Drummer)
.. die ersten DREI funktionieren schon mal prima. Es wird wohl nur der erste Button GRAU nach dem Klick. Auch die anderen Buttons sollen grau werden, wenn sie angeklickt wurden. Geht das noch?
Die anderen Buttons mit deinem Makro werde ich dann noch vervollständigen.
Wenn du mir noch die GRAU-Sache machen kannst, wäre prima.
Gruß
Dieter(Drummer)

Anzeige
AW: Sorry Karin, ist erledigt ...
21.10.2012 19:08:35
Dieter(Drummer)
... hatte altes Makro noch auf den Folge Buttons.
Danke dir für deine Mühe und prima Lösung.
Gruß
Dieter(Drummer)

AW: Jetzt hängt es ...
21.10.2012 19:28:09
Dieter(Drummer)
... Hi Karin,
habe mal einen neuen Button dazu in s Makro angehängt und es hängt (FETT in GELB):

Case "2 > 1"
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(57#, 132.75, 57#, 183.75).Select
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
End If
Was habe ich da falsch gemacht? Hier meine Datei: https://www.herber.de/bbs/user/82242.xls
Danke für evtl. neue Hilfe.
Gruß
Dieter(Drummer)

Anzeige
AW: Hab Fehler gefunden ...
21.10.2012 19:34:45
Dieter(Drummer)
... hatte ein altes .select mit übernommen. Habs entfernt und jetzt gehts prima.

With ActiveSheet.Shapes.AddLine(57#, 132.75, 57#, 183.75).Select

Danke und Sorry!!!
Lieben Gruß
Dieter(Drummer)

AW: Geschafft
22.10.2012 14:03:14
Dieter(Drummer)
Liebe Karin,
Danke nochmal für deine tolle Lösung und deine Bemühung. Hier ist nun die fertige Version, die auch prima funktioniert: https://www.herber.de/bbs/user/82252.xls
Manchmal musste ich wohl ausprobieren, dass keine Angaben von "Horizontal" oder "Vertical" notwendig waren. Nun geht's!
Ist es möglich, dass du mir noch eine Prüfung anfertigst, dass KEINE Pfeile mit IN BEIDE _ RICHTUNGEN PFEILSPITZEN zeigen, möglich ist. Z.B. Pfeil 

"1 > 2"
und dann 


"2 > 1"
. Dies sollte dann für alle Pfeile so sein. Wäre toll, wenn dies noch möglich wäre. Wenn nicht, kann ich auch damit Leben.
Das Ergebnis ist schon prima.
Lieben Gruß
Dieter(Drummer)

Anzeige
AW: Geschafft
22.10.2012 17:31:04
Beverly
Hi Dieter,
da gibt es 2 Möglichkeiten, die du innerhalb der Case-Anweisung einbauen musst.
Erste Möglichkeit: du fragst direkt ab, ob der betreffende "Gegen"-Button eine graue Beschriftung hat. Wenn nein, dann den Code zum Erstellen der Linie, andernfalls z.B. eine MsgBox, dass die "Gegen"-Linie bereits vorhanden ist - nach diesem Prinzip:
Sub PfeileEinfuegen()
With ActiveSheet.Shapes(ActiveSheet.Application.Caller)
Select Case ActiveSheet.Shapes(ActiveSheet.Application.Caller).DrawingObject.Caption
Case "1 > 2"
If ActiveSheet.Shapes("Schaltfläche 33").DrawingObject.Font.ColorIndex  48  _
Then
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(56.25, 132.75, 56.25, 183.75)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
End If
Else
MsgBox "Esgibt bereits einen Pfeil 2 > 1"
End If
Case "1 > 4"
Die zweite Möglichkeit: du müsstest in einer Schleife über alle Buttons laufen und prüfen, ob der "Gegen"-Button eine graue Beschriftung hat. Wenn nein, dann Linie erstellen, wenn ja, dann MsgBox dass "Gegen"-Linie schon vorhanden. Für die 2. Variante hier der prinzipielle Code: 
Sub PfeileEinfuegen()
Dim btnElement As Button
Dim blnBenutzt As Boolean
With ActiveSheet.Shapes(ActiveSheet.Application.Caller)
Select Case ActiveSheet.Shapes(ActiveSheet.Application.Caller).DrawingObject.Caption
Case "1 > 2"
If .DrawingObject.Font.ColorIndex  48 Then
For Each btnElement In ActiveSheet.Buttons
If btnElement.Caption = "2 > 1" Then
If btnElement.Font.ColorIndex = 48 Then
blnBenutzt = True
Exit For
End If
End If
Next btnElement
If blnBenutzt = False Then
With ActiveSheet.Shapes.AddLine(56.25, 132.75, 56.25, 183.75)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
Else
MsgBox "Es gibt bereits einen Pfeil 2 > 1"
End If
End If
Case "1 > 4"

Anzeige
AW: Geschafft
22.10.2012 18:18:47
Dieter(Drummer)
Hi Karin,
Danke für schnelle Arbeit und Rückmeldung. habe mal erste Variante eingesetzt und das geht noch _ nicht so richtig. Wenn ich 

"2 > 1"
anklicke wird Pfeil angezeigt. Wähle ich dann 


"1 > 2"
kommt die richte Meldung und Gegenpfeil erfolgt nicht. Fange ich aber mit 


"1 > 2"
an und wähle dann 


"2 >1"
wird der Gegenpfeil trotzdem gezeichnet. Ansonsten finde ich diese Variante prima. Das macht die Sache wohl komplizierter.
Gruß
Dieter(Drummer)

Anzeige
AW: Geschafft
22.10.2012 19:20:33
Beverly
Hi Dieter,
dein Code für diese beiden Schalter sieht so aus? 
With ActiveSheet.Shapes(ActiveSheet.Application.Caller)
Select Case ActiveSheet.Shapes(ActiveSheet.Application.Caller).DrawingObject.Caption
Case "1 > 2"
If ActiveSheet.Shapes("Schaltfläche 33").DrawingObject.Font.ColorIndex  48 Then
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(56.25, 132.75, 56.25, 183.75)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 48
End If
Else
MsgBox "Es gibt bereits einen Pfeil 2 > 1"
End If
Case "2 > 1"
If ActiveSheet.Shapes("Schaltfläche 81").DrawingObject.Font.ColorIndex  48 Then
If .DrawingObject.Font.ColorIndex  48 Then
With ActiveSheet.Shapes.AddLine(56.25, 131.25, 56.25, 183#)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipHorizontal
End With
.DrawingObject.Font.ColorIndex = 48
End If
Else
MsgBox "Es gibt bereits einen Pfeil 1 > 2"
End If

Anzeige
AW: Danke Karin ...
22.10.2012 19:23:40
Dieter(Drummer)
... werde das morgen austesten und melde mich.
Danke dir für deine prompte und perfekte Hilfe.
Lieben Gruß,
Dieter(Drummer)

AW: Danke Karin, funtktioniert perfekt ...
22.10.2012 20:22:15
Dieter(Drummer)
... lieben Dank für deine ermüdliche Hilfe und perfekte Lösung.
Gruß und einen schönen Abend
Dieter(Drummer)

AW: Fertig, aber mit noch einem Fehler
24.10.2012 10:58:30
Dieter(Drummer)
Hi Karin,
Dank deiner VBA Hilfe konnte ich jetzt das Makro vervollständigen und die Richtungspfeile funktioneren, auch mit dem Gegenpfeil-Hinweis. Herzlichen Dank dafür!
Ein Fehler taucht jetzt auf, beim "Pfeile löschen" in Modul2: 
ElseIf InStr(Shl.DrawingObject.Caption, " > ") > 0 Then
Die Zeile wird GELB angemarkert und Pfeile werden nicht gelöscht. Kannst du bitte nochmal drüber sehen und mir einen Tipp geben?! Hier die sonst fertige Datei: https://www.herber.de/bbs/user/82290.xls
Danke fürs drum kümmern und
Gruß
Dieter(Drummer)

Anzeige
anderer Tabelleninhalt
24.10.2012 15:25:23
Beverly
Hi Dieter,
deine Tabelle sieht jetzt anders aus, denn in deiner vorhergehenden Arbeitsmappe war das "Rechteck 802" nicht enthalten - dieses löst nun einen Fehler aus, da es die Eigentschaft Caption nicht kennt. Ändere den Code wie folgt:
Sub Pfeile_Linien_Loeschen()
Dim Shl As Object
For Each Shl In ActiveSheet.Shapes
If Shl.Type = 9 Then
Shl.Delete
ElseIf Shl.Type = 8 Then
If InStr(Shl.DrawingObject.Caption, " > ") > 0 Then _
Shl.DrawingObject.Font.ColorIndex = 5
End If
Next
End Sub

Anzeige
AW: Danke Karin, es funktioniert wieder!
24.10.2012 16:29:08
Dieter(Drummer)
Hi Karin,
was ist und wo sitz das "Rechteck 802"? Ansonsten meinen herzlichen Dank für deine erneute Hilfe und Lösung.
Lieben Gruß
Dieter(Drummer)

AW: Danke Karin, habs gefunden ...
24.10.2012 16:30:58
Dieter(Drummer)
... konnte es ausfindig machen.
Danke dir und lieben Gruß
Dieter(Drummer)

AW: Text in Zelle nach 8 Schaltflächen ROT
25.10.2012 12:23:04
Dieter(Drummer)
Hi Karin,
habe das Rechteck entfernt und die Vorgänger Version der "Pfeile löschen" wieder im Einsatz. Funktioniert auch prima.
Wunsch Makro:
1) Wenn ich 8 von den Schaltflächen aktiviert habe, die ich nach Klick auf ROT setze, ist das HAUS ja fertig und es soll in Zelle B2 der Text "Fertig" erscheinen.
2) ODER: Wenn 8 Pfeile "gezeichnet" sind, den Text "Fertig" in Zelle B2.
1) oder 2) würde schon ausreichen.
Noch eine komplizierte Frage/Lösung: Wenn ein Haus fertig "gezeichnet" ist, kann man die Reihenfolge der Pfeile z.B. ab Zelle A20 Unter- oder Nebeneinander (je Pfeil) eintragen und davor dann "V1" - für Version 1 - eintragen. Beim 2. fertigen Haus dann "V2" mit den Daten darunter usw. bis 44, ist ja max. Möglichkeit. So sind dann max. 44 Versionen untereinader gelistet. Wie ich dann doppelte Lösungen rausfiltere, muss ich dann mal sehen.
Ich hoffe nur, dass ich hier nicht zuviel Wünsche, da du mir schon sehr gut geholfen hast. Sollte es dennoch möglich sein, wäre einfach die Krönung.
Lieben Dank für's drum kümmern und
Gruß
Dieter(Drummer)
PS Nochmal letze Version meiner Datei als Link: https://www.herber.de/bbs/user/82311.xls

Anzeige
AW: Text in Zelle nach 8 Schaltflächen ROT
25.10.2012 17:49:35
Beverly
Hi Dieter,
deklariere außerhalb des Moduls eine Public-Variable zum Zählen - z.B. Public bytZaehler As Byte. Ergänze dann die eintelnen Case-Anweisungen wie folgt (Beispiel für Schalter "1 > 2":
         Case "1 > 2"
If ActiveSheet.Shapes("Schaltfläche 33").DrawingObject.Font.ColorIndex  3 Then
If .DrawingObject.Font.ColorIndex  3 Then
With ActiveSheet.Shapes.AddLine(56.25, 132.75, 56.25, 183.75)
.Line.EndArrowheadStyle = msoArrowheadTriangle
.Line.EndArrowheadLength = msoArrowheadLengthMedium
.Line.EndArrowheadWidth = msoArrowheadWidthMedium
.Flip msoFlipVertical
End With
.DrawingObject.Font.ColorIndex = 3
                    bytZaehler = bytZaehler + 1
If bytZaehler = 8 Then Auflisten
End If
Else
MsgBox "Es gibt bereits einen Pfeil 2 > 1"
End If
und füge eine neue Prozedur ein:
Sub Auflisten()
Dim lngZeile As Long
Dim btnElement As Button
Dim intSpalte As Integer
intSpalte = 2
lngZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows.Count) _
+ 1
If lngZeile  ") > 0 Then
If btnElement.Font.ColorIndex = 3 Then
Cells(lngZeile, intSpalte) = btnElement.Caption
intSpalte = intSpalte + 1
End If
End If
Next btnElement
Else
MsgBox "Keine weiteren Varianten möglich"
End If
Range("B2") = "Fertig"
bytZaehler = 0
End Sub
Die Prozedur zum Löschen der Pfeile ergänzt du noch um diese Zeile:
    Range("B2").ClearContents

Anzeige
AW: Danke Karin, da muss ich mal ran ...
25.10.2012 18:03:45
Dieter(Drummer)
... und das erstmal einarbeiten.
Dir, liebe Karin, erstmal herzlichen Dank für deine unermüdliche und kompentente Hilfe. Sobald ich das umsetzt habe melde ich mich.
Frage: Wie mach ich das? "deklariere außerhalb des Moduls eine Public-Variable zum Zählen - z.B. Public bytZaehler As Byte."
Lieben Gruß
Dieter(Drummer)

Anzeige
AW: Danke Karin, da muss ich mal ran ...
25.10.2012 18:18:26
Beverly
Hi Dieter,
die ersten beiden Zeilen im Modul1 sollten so aussehen:
Option Explicit
Public bytZaehler As Byte

AW: Wieder DANKE
25.10.2012 18:33:12
Dieter(Drummer)
... die anderen Makros werden ich Morgen wohl erst angepasst haben und melde mich.
Herzlichen Dank erstmal und noch einen schönen Abend.
Gruß
Dieter(Drummer)

Anzeige
AW: Falsche Pfeilrichtung verhindern
28.10.2012 11:10:50
Dieter(Drummer)
Liebe Karin,
du hast mir schon perfekt geholfen und dafür herzlichen Dank.
Es soll noch verhindert werden dass nach einem Setzen eines Pfeils, ein "falscher" Pfeil gesetzt wird.
Beispeil: Wie Datei : https://www.herber.de/bbs/user/82348.xls
z.B. Pfeile OK: 

1 > 2, 2 > 4, 4 > 3
, uns sowas sollte dann nicht möglich sein: 


4 > 5
(roter Pfeil). Es müsste dann mit 


4 > 2
weiter gehen. Das heißt, es darf nur in Pfeilspitze Richtung weiter gehen.
Ich hoffe, ich bitte nicht zuviel und du kannst mir weiter helfen. Habe auch Verständnis, wenn es zu viel ist.
Lieben Gruß
Dieter(Drummer)

Anzeige
AW: Text in Zelle nach 8 Schaltflächen ROT
25.10.2012 18:46:09
Dieter(Drummer)
Hi Karin,
diese Zeile wird beim einfügen des Makros "Auflisten" ROT angemarkert: 
    lngZeile = IIf(IsEmpty(Cells(Rows.Count, 1)), Cells(Rows.Count, 1).End(xlUp).Row, Rows. _
Count)_
1
Gruß
Dieter(Drummer)

AW: Text in Zelle nach 8 Schaltflächen ROT
25.10.2012 19:13:43
Beverly
Hi Dieter,
am Ende der Zeile muss stehen + 1

Anzeige
AW: Klappt jetzt alles prima. Danke!
25.10.2012 19:20:14
Dieter(Drummer)
Nochmals Danke für deine prima Lösungen, die alle hervorragend funktionieren.
Lieben Gruß
Dieter(Drummer)
;
Anzeige

Beliebteste Forumthreads (12 Monate)

Jetzt das Excel-Portal bewerten: Deine Stimme zählt!
Anzeige
Anzeige
Anzeige