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

[bilakos26]

Καλησπέρα σας! Στο αρχείο που σας παρέχω θέλω από το φύλλο εργασίας ΑΝΑΦΟΡΑ, τα ΠΟΣΑ ΔΑΠΑΝΗΣ που θα μετακινούνται στο ΑΡΧΕΙΟ, να μετακινούνται με ένα συγκεκριμένο χρώμα ανάλογα με την τιμή που έχει το κελί π.χ αν το κελί έχει τιμή μεγαλύτερη των 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

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

[kapetang]

Καλησπέρα

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

'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

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

[bilakos26]

Αρχική Δημοσίευση από kapetang

Καλησπέρα

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

'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

[kapetang]

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

    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

[bilakos26]

Αρχική Δημοσίευση από kapetang

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

    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

[kapetang]

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