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/3836-allagi-tis-timis-enos-kelioi-basei-toy-xromatos.html)

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

Γεια σε όλους!!!
Θα ήθελα τη βοήθειά σας σε κάτι που νομίζω ότι είναι απλό.
Από μία ιστοσελίδα αντιγράφω κάποια δεδομένα - κελιά (σε μορφή στήλης) Τα κελιά αυτά δεν έχουν τιμές, αλλά έχουν χρώμα γεμίσματος κόκκινο, ή κίτρινο ή πράσινο.
Αυτό που θα ήθελα είναι το εξής: Όταν κάνω επικόλληση των δεδομένων σε φύλλο του Excel, ξεκινώντας από το Α1, να μπαίνει στο κελί η τιμή 1 αν το χρώμα γεμίσματος είναι κόκκινο, 2 αν είναι κίτρινο και 3 αν είναι πράσινο.
Φαντάζομαι ότι το πρόβλημα λύνεται με έναν απλό κώδικα σε vba, αλλά δυστυχώς οι γνώσεις μου είναι ελάχιστες σε vba.

Η περιοχή που θα επικολλήσεις τα κελιά, έχει αρχή το a1
Οι γραμμές ή οι στήλες, είναι σταθερές ή μπορεί να αυξομειώνονται;

Για την ακρίβεια είναι το E1.
Ο αριθμός των γραμμών δεν είναι σταθερός. Το μέγιστο είναι η γραμμή 1000.
Άρα τα δεδομένα μου μπορεί να εκτείνονται στην περιοχή E1:E1000.

Καλημέρα
Έστω, η στήλη Ε, που έχει κελιά χρωματιστά.
Ο κώδικας:

Κώδικας:

Sub Macro1()

    Columns(5).Delete Shift:=xlToLeft

End Sub

διαγράφει όλη την στήλη ή
ο κώδικας:

Κώδικας:

Sub Macro2()

    With Columns(5).Interior

        .Pattern = xlNone

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    Columns(5).ClearContents

End Sub

καθαρίζει την στήλη.

Επέλεξε ένα εκ των δύο, που εξυπηρετεί καλύτερα.

Κάνεις paste στην Ε, τα κελιά, που έχεις αντιγράψει, από το δίκτυο.

Ο κώδικας (σύνδεσε ένα κουμπί):

Κώδικας:

Sub Macro3()

    Dim c As Range, rng As Range

    Set rng = Range("e1:e1000")

    Application.ScreenUpdating = False

    rng.ClearContents

    For Each c In rng

        Select Case c.Interior.Color

        Case vbRed

            c.Value = 1

        Case vbYellow

            c.Value = 2

        Case vbGreen

            c.Value = 3

        Case Else

            c.Value = vbNullString

        End Select

    Next

End Sub

υπολογίζει τις αξίες των κελιών, με βάση το χρώμα.

Σημειώσεις:
1
Δεν εξετάζονται, περεταίρω λεπτομέρειες, που αφορούν την δομή του φύλλου,
ή αυτοματισμοί, σε συμβάντα φύλλου.
2
Καθαρά χρώματα Office 2003

Σπύρο, σ' ευχαριστώ πολύ για τη βοήθειά σου.
Το πράσινο και το χρυσό (άλλαξα το yellow κι έβαλα gold) δε δουλεύουν. Φαντάζομαι ότι πρέπει να βρούμε τις ακριβείς τιμές RGB των δύο χρωμάτων και να βάλουμε αυτές τις τιμές αντί του vbGreen, αλλά και πάλι δεν ξέρω πώς γίνεται.
Σου επισυνάπτω το αρχείο για να δεις τα ακριβή χρώματα.

Όπως εξηγώ παραπάνω στις σημειώσεις:
«Καθαρά χρώματα Office 2003»

Γεια σου Σπύρο!
Με την παρακάτω εντολή
MsgBox Selection.Interior.ColorIndex
κατάφερα να βρω ότι το κόκκινό μου αντιστοιχεί στο ColorIndex 3, το χρυσό στο 44 και το πράσινο στο 10.
Οπότε με τον παρακάτω κώδικα η δουλειά μου γίνεται μια χαρά.
Dim c As Range, rng As Range
Set rng = Range("e1:e1000")
Application.ScreenUpdating = False
rng.ClearContents
For Each c In rng

If c.Interior.ColorIndex = 10 Then
c.Value = 3
ElseIf c.Interior.ColorIndex = 44 Then
c.Value = 2
ElseIf c.Interior.ColorIndex = 3 Then
c.Value = 1
End If

Next

Η βοήθειά σου ήταν πολύτιμη. Σ' ευχαριστώ πολύ και πάλι!!!

ωραία!
Γιατί άλλαξες με if την select case;

Δεν υπήρχε λόγος να την αλλάξω.
Απλώς εκείνη την ώρα έκανα κάποιες δοκιμές με If και συνέχισα με If.