VBA: per Button Ampel einfügen

Hallo VBA-Experten,
ich grübel und versuche schon seit Tagen obiges Problem zu lösen und bekomme es auch mit den Hilfen aus dem Forumsarchiv nicht hin.

Ich möchte unter verschiedenen Sachen per Button eine Ampel einfügen können, die mir den aktuellen Stand anzeigt.
Hinterher soll die Ampel wieder gelöscht werden, damit weitere Sachen in die Zeilen hinzugefügt werden können.

Spalte A ------- Spalte B ------- Spalte C------- Spalte D ... ------- Spalte W Spalte X ------- Y ------- Z
Standort1------- Regal1------- Regal2 ------- Regal3 ... ----- Mindestbestand Sache1 Sache2 Sache3
Sache1 ------- ------- 5 ------- ------- 2 ------- ------- 1 ------- ------- ------- ------- ------- ------- 10 ------- 5 ------- 2
Sache2 -------- -------1 ------- ------- 3 ------- ------- 3
Sache1 -------- ------ 0 ------- ------- 5 ------- ------- 2
Sache2 ------- ------- 2 ------- ------- 1 ------- ------- 0
Sache3 ------- ------- 2 ------- ------- 2 ------- ------- 4
...
Leerzeile/n ----- Ampel ------- Ampel -------- Ampel
...
Standort2
Sache3 ------- ------- 4 ------- ------- 3 ------- ------- 2
Sache2 ------- ------- 1 ------- ------- 3 ------- ------- 4
Sache1
Sache2
... -------- ------- ----- Ampel ------- Ampel -------- Ampel
Leerzeile/n
...
Standort3
usw.

Die Schwierigkeit liegt darin, dass die Ampel die Sache in Spalte A erkennen, für ein Regal zählen und überprüfen muss, ob der Mindestbestand noch vorhanden ist. Es können auch weitere Sachen zu den Standorten kommen, daher muss beim Setzen der Ampel die Range.Row in Spalte A ermittelt werden (die Bezeichnung Standort(x) könnte der Indikator für das Ende der Ampelfunktion sein).
Nach dem Auswerten wird / werden die Ampel/n gelöscht.
Später wird sie dann wieder unter dem letzten Eintrag des Standorts, für eine neue Auswertung gesetzt.

Ganz schön kompliziert oder?
Vielleicht hat ja jemand Lust die Nuss zu knacken...

Viele Grüße
Georgi

Hallo Georgi

entschuldigung, die Firmenphilosophie hatte ich nicht bedacht! Hier der Code.
Ich habe ihn erweitert auf drei Codes. Einen zum Zellen einfügen und zum löschen.
Bei Const Amp1 kannst du die Farben selbst festlegen.
Const Mxx ist mehrfacher Mindestbestand!

Mehrfach heisst, über Mindestbestand wird gelb angezeigt, bei mehrfacher Bestand grün.
Ab wann du mehrfach Bestand definierst musst du entscheiden. Viel Spass beim testen.
Für interessierte Forum Leser lade ich die geänderte Datei noch mal hoch.
https://www.herber.de/bbs/user/172727.xlsm

mfg Piet



Dim AC As Range, j, li1 As Long       '7.10.2024  Piet  Herber Forum

Dim Mwt1, Mwt2, Mwt3   'Mindestwerte

Dim Reg1, Reg2, Reg3   'Regale 1-3

Const Amp1 = 255       'rot Innenfarbe

Const Amp2 = 65535     'gelb

Const Amp3 = 5287936   'grün

Const Mxx = 3   '3fach Mindestbestand





Sub Ampel_ausfüllen()

    lz1 = Cells(Rows.Count, 1).End(xlUp).Row

    Range("B2:D" & lz1).Interior.Color = xlNone

    For Each AC In Range("A2:A" & lz1)

        If Left(AC, 8) = "Standort" Then

           Reg1 = 0: Reg2 = 0: Reg3 = 0

           Mwt1 = Cells(AC.Row, "X")

           Mwt2 = Cells(AC.Row, "Y")

           Mwt3 = Cells(AC.Row, "Z")

        ElseIf AC.Value = "Ampel" Then

           AC.Cells(1, 2) = Reg1

           AC.Cells(1, 3) = Reg2

           AC.Cells(1, 4) = Reg3

           AC.Cells(1, 2).Interior.Color = Amp1

           AC.Cells(1, 3).Interior.Color = Amp2

           AC.Cells(1, 4).Interior.Color = Amp3

           If Reg1  Mwt1 Then AC.Cells(1, 2).Interior.Color = Amp1

           If Reg2  Mwt2 Then AC.Cells(1, 3).Interior.Color = Amp2

           If Reg2  Mwt2 Then AC.Cells(1, 4).Interior.Color = Amp3

           If Reg1 > Mwt1 * Mxx Then AC.Cells(1, 2).Interior.Color = Amp3

           If Reg2 > Mwt2 * Mxx Then AC.Cells(1, 3).Interior.Color = Amp3

           If Reg2 > Mwt2 * Mxx Then AC.Cells(1, 4).Interior.Color = Amp3

        Else  'Regalwerte laden

           Reg1 = Reg1 + AC.Cells(1, 2)

           Reg2 = Reg2 + AC.Cells(1, 3)

           Reg3 = Reg3 + AC.Cells(1, 4)

        End If

    Next AC

End Sub







Sub Ampel_Zeilen_einfügen()

    lz1 = Cells(Rows.Count, 1).End(xlUp).Row

    Cells(lz1 + 1, 1) = "Ampel"

    Cells(lz1 + 1, 1).Font.Color = 192

    For j = lz1 To 2 Step -1

        If Left(Cells(j, 1), 8) = "Standort" Then

           Rows(j - 1).Insert shift = xlDown

           Cells(j - 1, 1) = "Ampel"

           Cells(j - 1, 1).Font.Color = 192

        End If

    Next j

End Sub





Sub Ampel_Zeilen_löschen()

    lz1 = Cells(Rows.Count, 1).End(xlUp).Row

    For j = lz1 To 2 Step -1

        If Cells(j, 1) = "Ampel" Then _

           Rows(j).Delete shift = xlUp

    Next j

End Sub

Forumthread: VBA: per Button Ampel einfügen

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

VBA: per Button Ampel einfügen

Forumthread: VBA: per Button Ampel einfügen

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread