Come riprodurre il colore Sfumato di una Cella

Question

Ciao a Tutti,

Ero abituato con excel 2003 , che dovendo copiare il colore di una cella in un altra, bastava leggere colorindex e a quel punto la copia colore era fatta.

Con Excel2007 , con la magnifica colorazione a sfumatura, fare la copia è più complesso. Ho registrato una macro per colorare con sfumatura una cella. Poi volevo leggere le stese proprietà impostate dalla macro, e utilizzarle per impostare altre celle con stesso colore. Qui a seguire il codice che NON funziona.

Perchè nell'Help non trovo i membri di .Interior.Gradient , quando invece me li aspetterei  ?? Forse non mi è chiaro un concetto ?? Dalla macro, infatti non mi dovrei aspettare che Gradient ha almeno colorstop come membro ??

Qualcuno mi potrebbe dare chiarimenti. Grazie Anticipatamente.

Public Sub CaricaColori(ByVal nomefoglio As String, ByRef cl As Object)

    Dim rif As String

    Dim wb As Workbook

    Dim rec As Worksheet

    Dim maxc As New ColoriMax           'Classe Utente

    Dim c1, c2, c3, c4, c5 As Variant

    Dim rng As Range

    Set wb = ActiveWorkbook

    Set rec = Worksheets(nomefoglio)

    rec.Activate                        'IMPORTANTISSIMO , SENZA QUESTO NON LAVORAVA

    Set maxc = cl

    rif = wb.Names("TABELLA_COLORI").value

    temp = AddrCella(rif)                   '"$C$2;$G$10"

    If temp <> "" Then

       Set rng = Range(temp).Cells(1, 3)    'vado a selezionare ogni cella della tabella colori

       rng.Select

       With Selection

        c1 = .Interior.ColorIndex

        c2 = .Interior.Pattern

        c3 = .Interior.Gradient.Degree

        'c4 = .Interior.Gradient.ColorStop  '!!! NON FUNZIONA

       End With

       rec.Cells(1, 1).Select               'PROVO A COLORARE UNA CELLA CON COLORINDEX DELLA TABELLA

       With Selection.Interior

            rec.Cells(1, 1).Interior.ColorIndex = c1

       End With

    'DI SEGUITO IL RISULTATO DELLA MACRO PER COLORARE LA TABELLA COLORI

    Range("A2:A3").Select

    With Selection

        .Merge

    End With

    Selection.Borders(xlEdgeBottom).LineStyle = True

    Selection.Borders(xlEdgeTop).LineStyle = True

    Selection.Borders(xlEdgeLeft).LineStyle = True

    Selection.Borders(xlEdgeRight).LineStyle = True

    With Selection.Interior

        .Pattern = xlPatternLinearGradient

        .Gradient.Degree = 90

        .Gradient.ColorStops.Clear

    End With

    With Selection.Interior.Gradient.ColorStops.Add(0)

        .color = 65535

        .TintAndShade = 0

    End With

    With Selection.Interior.Gradient.ColorStops.Add(1)

        .color = 6087918

        .TintAndShade = 0

    End With

    End If

End Sub

Answer 1

Mi mancherebbe poi il controllo se lo stile esiste già ! mi potresti aiutare ??

Vediamo un po', lunghetto. Questa macro crea ogni volta uno style assegnandogli un nome diverso, tipo Style48, Style49, ecc.:

Public Sub m()

    Dim wk As Workbook

    Dim sh As Worksheet

    Dim lStyles As Long

    Set wk = ThisWorkbook

    Set sh = wk.Worksheets("Foglio1")

    With wk

        lStyles = .Styles.Count + 1

        .Styles.Add ("Style" & lStyles)

        With .Styles("Style" & lStyles)

            .IncludeNumber = True

            .IncludeFont = True

            .IncludeAlignment = True

            .IncludeBorder = True

            .IncludePatterns = True

            .IncludeProtection = True

        End With

        With .Styles("Style" & lStyles).Font

            .Name = "Calibri"

            .Size = 11

            .Bold = True

            .Italic = False

            .Underline = xlUnderlineStyleNone

            .Strikethrough = False

            .ThemeColor = 1

            .TintAndShade = 0

            .ThemeFont = xlThemeFontMinor

        End With

        With .Styles("Style" & lStyles).Interior

            .Pattern = xlSolid

            .PatternColorIndex = 0

            .ThemeColor = xlThemeColorAccent3

            .TintAndShade = 0

            .PatternTintAndShade = 0

        End With

    End With

    Set sh = Nothing

    Set wk = Nothing

End Sub

Volendo, poso passare alla macro dei parametri di formattazione relativi ad una cella formattata in precedenza senza Style:

Public Sub m(ByVal rng As Range)

    Dim wk As Workbook

    Dim lStyles As Long

    Set wk = ThisWorkbook

    With wk

        lStyles = .Styles.Count + 1

        .Styles.Add ("Style" & lStyles)

        With .Styles("Style" & lStyles)

            .IncludeNumber = True

            .IncludeFont = True

            .IncludeAlignment = True

            .IncludeBorder = True

            .IncludePatterns = True

            .IncludeProtection = True

        End With

        With .Styles("Style" & lStyles).Font

            .Name = rng.Font.Name

            .Size = rng.Font.Size

            .Bold = rng.Font.Bold

            .Italic = rng.Font.Italic

            .Underline = rng.Font.Underline

            .Strikethrough = rng.Font.Strikethrough

            .TintAndShade = rng.Font.TintAndShade

        End With

        With .Styles("Style" & lStyles).Interior

            .Pattern = rng.Interior.Pattern

            .PatternColorIndex = rng.Interior.PatternColorIndex

            .ColorIndex = rng.Interior.ColorIndex

            .TintAndShade = rng.Interior.TintAndShade

            .PatternTintAndShade = rng.Interior.PatternTintAndShade

        End With

    End With

    Set wk = Nothing

End Sub

Con la macro qui sotto richiamiamo m() e le passiamo appunto come parametro la cella A1 del Foglio1, creando uno Style in base alla formattazione di A1:

Public Sub m_1()

    Dim sh As Worksheet

    Dim rng As Range

    Set sh = ThisWorkbook.Worksheets("Foglio1")

    With sh

        Set rng = .Range("A1")

        Call m(rng)

    End With

    Set sh = Nothing

    Set rng = Nothing

End Sub

Possaimo ovviamente creare più Styles in base alle formattazioni di un gruppo di celle, qui A1:A5 del Foglio1:

Public Sub m_1()

    Dim sh As Worksheet

    Dim rng As Range

    Dim c As Range

    Set sh = ThisWorkbook.Worksheets("Foglio1")

    With sh

        Set rng = .Range("A1:A5")

        For Each c In rng

            Call m(c)

        Next

    End With

    Set c = Nothing

    Set sh = Nothing

    Set rng = Nothing

End Sub

Più che altro devi sperimentare, anche perchè ho notato che alcune proprietà degli Styles non corrispondono alle proprietà delle celle. Tu mi chiedevi come fare per sapere se un nome è già presente. Io aggiro il problema con un numero progressivo(credo che nel codice si veda). Puoi comunque ciclare l'insieme Styles e controllare la presenza o meno di un nome: esempio:

Public Sub m_2()

    Dim oStyle As Style

    For Each oStyle In ThisWorkbook.Styles

        MsgBox oStyle.Name

    Next

    Set oStyle = Nothing

End Sub

Non credo sia difficile sostituire alla MsgBox la gestione dei nomi. Per assegnare invece uno Style ad una cella(qui la cella attiva):

Public Sub m_3()

    ActiveCell.Style = "NomeDelloStyle"

End Sub

---

--

La soluzione, il codice ed i files sono forniti *così come sono* e l’autore declina ogni responsabilità per eventuali problemi causati dalla soluzione proposta se usata impropriamente. Create e utilizzate una copia del file per le vostre prove, *prima* di utilizzare la soluzione in files importanti.

--

Mauro Gamberini - Microsoft© MVP(Excel)

http://www.maurogsc.eu/

Answer 2

<cut>

Aggiungo che una macro del genere si potrebbe anche parametrizzare:

Public Sub mConParametri(ByVal v As Variant)

    With v

        .Borders(xlEdgeBottom).LineStyle = True

        .Borders(xlEdgeTop).LineStyle = True

        .Borders(xlEdgeLeft).LineStyle = True

        .Borders(xlEdgeRight).LineStyle = True

        With .Interior

            .Pattern = xlPatternLinearGradient

            .Gradient.Degree = 90

            .Gradient.ColorStops.Clear

            With .Gradient.ColorStops

                With .Add(0)

                    .Color = 65535

                    .TintAndShade = 0

                End With

                With .Add(1)

                    .Color = 6087918

                    .TintAndShade = 0

                End With

            End With

        End With

    End With

End Sub

Richiamandola poi ad esempio così:

Public Sub m_1()

    Call mConParametri(ActiveSheet.Range("A1:A10"))

End Sub

Public Sub m_2()

    Call mConParametri(Selection)

End Sub

Public Sub m_3()

    Call mConParametri(Foglio3.Range("A1:A10"))

End Sub

eccetera...

Però, la cosa migliore ritengo sia utilizzare uno Style. Lo imposti(da codice o manualmente) e poi:

Selection.Style = "Nome dello Style"

dove Selection puoi sostituirla con riferimenti a celle, esempio: nomefoglio.Range("A1").Style = "Nome dello Style".

Per la creazione e gestione dell'oggeto Style, vedi nella guida del vb di Excel: Oggetto Style e link correlati. Se hai problemi, siamo(quasi) sempre qui. Un consiglio: utilizza il meno possibile Select/Activequalcosa. Sono solo forieri di pasticci.

---

--

La soluzione, il codice ed i files sono forniti *così come sono* e l’autore declina ogni responsabilità per eventuali problemi causati dalla soluzione proposta se usata impropriamente. Create e utilizzate una copia del file per le vostre prove, *prima* di utilizzare la soluzione in files importanti.

--

Mauro Gamberini - Microsoft© MVP(Excel)

http://www.maurogsc.eu/

Answer 3

Ok , la macro cosi' fatta mi fà la cella desiderata. Ora però un'altra sub , dovrebbe andare a vedere come è colorata la cella B3, per andarmi a colorare

un'altra cella E9 in modo identico. Ho provato a copiare ogni singolo parametro come segue:

        ... e sembra funzioni. Mi chiedevo però come fare per leggere in una sola riga l' item(0) e l'item(1) di ColorStops ( ottenuti con Add(0) e Add(1))

<cut>

        With .Interior.Gradient.ColorStops

            c1 = .Item(0)

            c2 = .Item(1)

        End With

NON Funziona !

Ciao e Grazie

 

 

E usare:

    '.........

        .Range("B3").Copy

        .Range("E9").PasteSpecial Paste:=xlPasteFormats

    '...........

   non è più semplice?

---

--

La soluzione, il codice ed i files sono forniti *così come sono* e l’autore declina ogni responsabilità per eventuali problemi causati dalla soluzione proposta se usata impropriamente. Create e utilizzate una copia del file per le vostre prove, *prima* di utilizzare la soluzione in files importanti.

--

Mauro Gamberini - Microsoft© MVP(Excel)

http://www.maurogsc.eu/

Answer 4

Grazie Mauro, che sei sempre gentilissimo,

Ok , la macro cosi' fatta mi fà la cella desiderata. Ora però un'altra sub , dovrebbe andare a vedere come è colorata la cella B3, per andarmi a colorare

un'altra cella E9 in modo identico. Ho provato a copiare ogni singolo parametro come segue:

        Dim c1, c2, c3, c4, c5, c6 As Variant

        With .Interior

            c1 = .Pattern

            c2 = .Gradient.Degree

            With .Gradient.ColorStops

                With .Add(0)

                    c3 = .color

                    c4 = .TintAndShade

                End With

                With .Add(1)

                    c5 = .color

                    c6 = .TintAndShade

                End With

            End With

        End With

... e sembra funzioni. Mi chiedevo però come fare per leggere in una sola riga l' item(0) e l'item(1) di ColorStops ( ottenuti con Add(0) e Add(1))

in modo da caricare insieme .color e .TintAndShade.

Infatti

        With .Interior.Gradient.ColorStops

            c1 = .Item(0)

            c2 = .Item(1)

        End With

NON Funziona !

Ciao e Grazie

Answer 5

Ciao a Tutti,

Ero abituato con excel 2003 , che dovendo copiare il colore di una cella in un altra, bastava leggere colorindex e a quel punto la copia colore era fatta.

Con Excel2007 , con la magnifica colorazione a sfumatura, fare la copia è più complesso.

<cut>

Questa fa quanto mi aspetto, Foglio1, cella A1:

Public Sub m()

    Dim sh As Worksheet

    Set sh = ThisWorkbook.Worksheets("Foglio1")

    With sh.Range("A1")

        .Borders(xlEdgeBottom).LineStyle = True

        .Borders(xlEdgeTop).LineStyle = True

        .Borders(xlEdgeLeft).LineStyle = True

        .Borders(xlEdgeRight).LineStyle = True

        With .Interior

            .Pattern = xlPatternLinearGradient

            .Gradient.Degree = 90

            .Gradient.ColorStops.Clear

            With .Gradient.ColorStops

                With .Add(0)

                    .Color = 65535

                    .TintAndShade = 0

                End With

                With .Add(1)

                    .Color = 6087918

                    .TintAndShade = 0

                End With

            End With

        End With

    End With

    Set sh = Nothing

End Sub

Esistono anche gli stili(Style), gestibili sempre da vb e forse più adatti allo scopo.

---

--

La soluzione, il codice ed i files sono forniti *così come sono* e l’autore declina ogni responsabilità per eventuali problemi causati dalla soluzione proposta se usata impropriamente. Create e utilizzate una copia del file per le vostre prove, *prima* di utilizzare la soluzione in files importanti.

--

Mauro Gamberini - Microsoft© MVP(Excel)

http://www.maurogsc.eu/