Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1660to1664
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA - Prozentualer Anteil nach Farben

VBA - Prozentualer Anteil nach Farben
20.12.2018 08:18:23
Moritz
Guten Morgen zusammen,
Ich möchte eine kleine Übersicht zum prozentualen Anteil der Lieferanten in einer Preisübersicht erstellen.
Bsp.: Lieferant X - 29% | Lieferant Y - 41% | Lieferant Z 30% (Anteil in der Preisliste)
basierend auf den Farben in den Zellen.
Ich habe im Internet gelesen, dass man hierfür ein Makro benötigt.
Wenn ich mich diesbezüglich täusche, belehrt mich gerne eines Besseren :-)
In der Beispieldatei sind die besten Preise je nach Lieferant mit Farbe hinterlegt.
Die Ergebnisse sollen demnach in den Zellen C18:C20 stehen.
https://www.herber.de/bbs/user/126224.xlsm
Der Aufbau in der Originaldatei ist der gleiche, allerdings stehen die Preise in den Zellen I2:AN72
Vielen Dank im Voraus
Liebe Grüße
Moritz

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA - Prozentualer Anteil nach Farben
20.12.2018 09:04:21
UweD
Hallo
so...
Sub Farben_zählen()
    Dim TB, RNG As Range, Zrng As Range
    Dim F1 As Double, F2 As Double, F3 As Double, Ges As Double
    Dim Z
    
    Set TB = Sheets("Empfehlung")
    Set RNG = TB.Range("I2:W15") 'oder "I2:AN72" 
    Set Zrng = TB.Range("B18")
    
    Ges = WorksheetFunction.Sum(RNG)
    
    For Each Z In RNG
        Select Case Z.Interior.Color
        
            Case Zrng.Interior.Color 'grau 
                F1 = F1 + Z.Value
            
            Case Zrng.Offset(1, 0).Interior.Color 'blau 
                F2 = F2 + Z.Value

            Case Zrng.Offset(2, 0).Interior.Color 'grün 
                F3 = F3 + Z.Value
                
            Case Else
                MsgBox "Fehlende Farbe in Zelle " & Z.Address
                Exit Sub
        End Select
    Next
    Zrng.Offset(0, 1) = F1 / Ges
    Zrng.Offset(1, 1) = F2 / Ges
    Zrng.Offset(2, 1) = F3 / Ges
End Sub
LG UweD
Anzeige
AW: VBA - Prozentualer Anteil nach Farben - Danke
20.12.2018 09:21:05
Moritz
Hallo Uwe,
Vielen lieben Dank!
Funktioniert perfekt!
Ich wünsche frohe Weihnachten und einen guten Rutsch ins neue Jahr.
Liebe Grüße
Moritz

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige