Farbfelder übertragen wenn ID gleich

Forumthread: Farbfelder übertragen wenn ID gleich

Matthias

Guten Morgen Excelfreunde,
meine VBA Kenntnisse sind noch dürftig und ohne diese wird es nicht gehen,
also suche ich wieder einmal Rat bei Euch.
Es soll eine ID verglichen werden, wenn diese übereinstimmt, wird in der nebenstehenden Spalte
Die Zelle je nach Bedingung eingefärbt. Ich habe eine abgespeckte Musterdatei beigefügt schaut es
Euch bitte einmal an.
Ich freue mich auf Eure zusammenarbeit.
Anlage: https://www.herber.de/bbs/user/76337.xlsm
Gruß Matze

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Bedingtes Format - ohne VBA

24.08.2011 08:05:03

Erich

Hi Matze,
warum sollte das nicht ohne VBA gehen? Excel gut?
Ein Vorschlag:
Tabelle1

	A	B	C
2	ID	Stk-Zahl	Min
3	13	125	72
4	19	125
5	23	130	-66
6	14	100	-32
7	17	100	88
8	18	120	122
9	22	100	69

Formeln der Tabelle

Zelle	Formel
C3	{=WENN(ISTNV(VERGLEICH(A3;$A$15:$A$20;0)); "";MIN(WENN($A$15:$A$20=A3;$B$15:$F$20)))}

Enthält Matrixformel:
Umrandende { } nicht miteingeben,
sondern Formel mit STRG+SHIFT+RETURN abschließen!

Matrix verstehen

Bedingte Formatierungen der Tabelle

Zelle	Nr.: / Bedingung	Format
B3	1. / Formel ist =$C3<0	Abc
B3	2. / Formel ist =$C3<=75	Abc
B4	1. / Formel ist =$C3<0	Abc
B4	2. / Formel ist =$C3<=75	Abc
B5	1. / Formel ist =$C3<0	Abc
B5	2. / Formel ist =$C3<=75	Abc
B6	1. / Formel ist =$C3<0	Abc
B6	2. / Formel ist =$C3<=75	Abc
B7	1. / Formel ist =$C3<0	Abc
B7	2. / Formel ist =$C3<=75	Abc
B8	1. / Formel ist =$C3<0	Abc
B8	2. / Formel ist =$C3<=75	Abc
B9	1. / Formel ist =$C3<0	Abc
B9	2. / Formel ist =$C3<=75	Abc

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

VBA Lösung gesucht - Danke Erich

24.08.2011 09:03:06

Matthias

Da hätte der Matze ja selbst drauf kommen können,
prima , ich würde aber gerne offen lassen und mir eine VBA Lösung ansehen-
Danke
Gruß Matze

AW: VBA Lösung gesucht - Danke Erich

24.08.2011 11:51:00

Tino

Hallo,
hier mal eine Variante, evtl. müsstest Du die Bereiche und die Tabelle anpassen
wenn es nicht wie im Beispiel aufgebaut ist.

Sub Test()
Dim ArrayData, n&, nn&, nnn&, nMaxColor&, lngColor&
Dim rng As Range
Dim iCalc%

Const lngRot& = 255
Const lngOrange& = 49407

With Tabelle1 'tabelle anpassen 
    ArrayData = .Range("A15", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 6)
    Set rng = .Range("A3", .Cells(3, 1).End(xlDown)).Resize(, 2)
End With

With Application
    iCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    
        With .WorksheetFunction
            nMaxColor = .Max(lngRot, lngOrange) + 1
            
            For n = 1 To rng.Rows.Count
                lngColor = nMaxColor
                For nn = 1 To Ubound(ArrayData)
                    If ArrayData(nn, 1) = rng(n, 1).Value Then
                        For nnn = 2 To Ubound(ArrayData, 2)
                            Select Case ArrayData(nn, nnn)
                                Case Is < 0
                                    lngColor = lngRot 'rot 
                                    Exit For
                                Case 0 To 75
                                    lngColor = .Min(lngColor, lngOrange) 'orange 
                            End Select
                        Next nnn
                        Exit For
                    End If
                Next nn
                
                If lngColor = nMaxColor Then lngColor = xlColorIndexNone
                rng(n, 2).Interior.Color = lngColor
            Next n
        End With
    
    .Calculation = iCalc
    .ScreenUpdating = False
    .EnableEvents = False
End With
End Sub

Gruß Tino

Wenn's VBA sein soll...

24.08.2011 11:57:18

Erich

Hi Matze,
... dann probier mal


Option Explicit
Sub Faerbe()
Dim rngC As Range, arrID, varF, dblM As Double
arrID = Range(Cells(15, 1), Cells(15, 1).End(xlDown))
For Each rngC In Range(Cells(3, 1), Cells(3, 1).End(xlDown))
varF = Application.Match(rngC, arrID, 0)
If IsNumeric(varF) Then
dblM = Application.Min(Cells(14 + varF, 2).Resize(, 5))
Select Case dblM
Case Is

Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Danke euch Beiden

24.08.2011 12:02:32

Matthias

Werde mir das erst heute Abend ansehen können,
sieht aber vielversprechend aus, somit hab ich wieder was zu lernen.
Danke... werde dieses Forum immer gerne weiterempfehlen.
Gruß Matze

Beliebteste Forumthreads (12 Monate)

Farbfelder übertragen wenn ID gleich

Forumthread: Farbfelder übertragen wenn ID gleich

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread