Forum - VBA Αλλαγή χρώματος κελιού ανάλογα με την τιμή του κελιού

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [VBA] Αλλαγή χρώματος κελιού ανάλογα με την τιμή του κελιού (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/4740-allagi-xromatos-kelioi-analoga-me-tin-timi-toy-kelioi.html)

Αλλαγή χρώματος κελιού ανάλογα με την τιμή του κελιού

Καλησπέρα σας! Στο αρχείο που σας παρέχω θέλω από το φύλλο εργασίας ΑΝΑΦΟΡΑ, τα ΠΟΣΑ ΔΑΠΑΝΗΣ που θα μετακινούνται στο ΑΡΧΕΙΟ, να μετακινούνται με ένα συγκεκριμένο χρώμα ανάλογα με την τιμή που έχει το κελί π.χ αν το κελί έχει τιμή μεγαλύτερη των 10€, η τιμή που θα μεταφερθεί στο στο κελί του ΑΡΧΕΙΟΥ να έχει χρώμα κόκκινο.
Ο κώδικας που έχω γράψει με VBA μέχρι στιγμής, αλλάζει τα χρώματα που θέλω, αλλά κάθε φορά γίνεται όλο και πιο αργός διότι κάνει αναζήτηση των τιμών στο ΑΡΧΕΙΟ για τις τιμές που του έχω ορίσει να αλλάζει χρώμα. Στον κώδικα τις τιμές αυτές, τις ορίζω στο 'GEMISMA XROMATOS
Αυτό όμως που θέλω εγώ, είναι το χρώμα του κελιού στο οποίο θα μεταφερθεί η τιμή να αλλάζει την στιγμή που θα μεταφερθεί η τιμή, έτσι ώστε να γίνονται οι συγκρίσεις εκείνη την στιγμή.

Προς το παρών οι τιμές από το φύλλο ΑΝΑΦΟΡΑ, μεταφέρονται στο ΑΡΧΕΙΟ με αυτόν τον κώδικα:

Κώδικας:

'METAKINHSH SE ARXEIO

k = 4

Do While Worksheets("ΑΝΑΦΟΡΑ").Cells(k, 1) <> ""

  k = k + 1

Loop

k = k - 1
 

l = 2

Do While Worksheets("ΑΡΧΕΙΟ").Cells(l, 1) <> ""

  l = l + 1

Loop
 

For j = 9 To k

    Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 1) = Worksheets("ΑΝΑΦΟΡΑ").Cells(4, 2) 'ημερα

    Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 2) = Worksheets("ΑΝΑΦΟΡΑ").Cells(5, 2) 'ΜΗΝΑΣ

    Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 3) = Worksheets("ΑΝΑΦΟΡΑ.Cells(6, 2) 'ΗΜ/ΝΙΑ

    Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 4) = Worksheets("ΑΝΑΦΟΡΑ").Cells(7, 2) 'ΩΡΑ

    Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 5) = Worksheets("ΑΝΑΦΟΡΑ").Cells(8, 2) 'ΕΙΔΟΣ ΔΑΠΑΝΗΣ

    Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) = Worksheets("ΑΝΑΦΟΡΑ").Cells(9, 2) 'ΠΟΣΟ ΔΑΠΑΝΗΣ
 

Next j

Σε αυτό το σημείο προσπάθησα να βάλω τον κώδικα που θα παραθέσω παρακάτω, έτσι ώστε να μου γίνεται απευθείας η αλλαγή χρώματος αλλά ο κώδικας έβγαζε error :

Κώδικας:

 
 

    If Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) >= 10 Then Cell.Interior.ColorIndex = 3

    ElseIf Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) < 10 Then Cell.Interior.ColorIndex = 0

    ElseIf Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) <= 9.99 Then Cell.Interior.ColorIndex = 14

    ElseIf Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) <= 7 Then Cell.Interior.ColorIndex = 4

    ElseIf Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) < 4 Then Cell.Interior.ColorIndex = 0

    ElseIf Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6) <= 4 Then Cell.Interior.ColorIndex = 45

    End If

Μπορείτε να με βοηθήσετε με το πρόβλημά μου;

Καλησπέρα

Βασίλη, δοκίμασε τον κώδικα:

Κώδικας:

'GEMISMA XROMATOS

    lRow = Sheets("ΑΡΧΕΙΟ").Range("F" & Rows.Count).End(xlUp).Row

    Set MR = Sheets("ΑΡΧΕΙΟ").Range("F2:F" & lRow)

    

    For Each cell In MR

        Select Case cell

        Case Is <= 4

            cell.Interior.ColorIndex = 45

        Case Is <= 7

            cell.Interior.ColorIndex = 4

        Case Is < 10

            cell.Interior.ColorIndex = 14

        Case Else

            cell.Interior.ColorIndex = 3

        End Select

    Next

Αντί για κώδικα θα μπορούσες να χρησιμοποιήσεις μορφοποίηση υπό όρους.

Παράθεση:

Αρχική Δημοσίευση από kapetang (Μήνυμα 26906)

Καλησπέρα

Βασίλη, δοκίμασε τον κώδικα:

Κώδικας:

'GEMISMA XROMATOS

    lRow = Sheets("ΑΡΧΕΙΟ").Range("F" & Rows.Count).End(xlUp).Row

    Set MR = Sheets("ΑΡΧΕΙΟ").Range("F2:F" & lRow)

    

    For Each cell In MR

        Select Case cell

        Case Is <= 4

            cell.Interior.ColorIndex = 45

        Case Is <= 7

            cell.Interior.ColorIndex = 4

        Case Is < 10

            cell.Interior.ColorIndex = 14

        Case Else

            cell.Interior.ColorIndex = 3

        End Select

    Next

Αντί για κώδικα θα μπορούσες να χρησιμοποιήσεις μορφοποίηση υπό όρους.

Θα μπορούσε η αλλαγή χρώματος να γίνει την στιγμή που γίνεται η μετακίνηση στο κελί;; αντί να κάθεται και να ψάχνει όλα τα κελιά της σειράς; εννοώ να μπει στο σημείο του κώδικα 'METAKINHSH SE ARXEIO

Πρόσθεσε μετά τη μετακίνηση και πριν από το άδειασμα τον κώδικα:

Κώδικας:

    Set cell = Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6).Offset(-1)

    Select Case cell

    Case Is <= 4

        cell.Interior.ColorIndex = 45

    Case Is <= 7

        cell.Interior.ColorIndex = 4

    Case Is < 10

        cell.Interior.ColorIndex = 14

    Case Else

        cell.Interior.ColorIndex = 3

    End Select

Παράθεση:

Αρχική Δημοσίευση από kapetang (Μήνυμα 26910)

Πρόσθεσε μετά τη μετακίνηση και πριν από το άδειασμα τον κώδικα:

Κώδικας:

    Set cell = Worksheets("ΑΡΧΕΙΟ").Cells(l + j - 9, 6).Offset(-1)

    Select Case cell

    Case Is <= 4

        cell.Interior.ColorIndex = 45

    Case Is <= 7

        cell.Interior.ColorIndex = 4

    Case Is < 10

        cell.Interior.ColorIndex = 14

    Case Else

        cell.Interior.ColorIndex = 3

    End Select

Ο κώδικας αυτός έκανε ακριβώς αυτό που ήθελα!
Είσαι φανταστικός!! Σε ευχαριστώ πολύ :D

Να είσαι καλά!