Colore di sfondo sfumato tramite macro.

Anonimo
2020-03-30T17:31:31+00:00

Ciao,

ho preso spunto da un suggerimento di Norman per avere nelle celle il colore di sfondo sfumato:

Option Explicit

Public rCell As Range

Sub SetFormat(aRng As Range)

    Set rCell = Selection

    With Application

        .ScreenUpdating = False

        .EnableEvents = False

    End With

    aRng.Select

    Application.EnableEvents = True

    aRng.FormatConditions.Add Type:=xlExpression, Formula1:= _

                              "=" & aRng.Offset(0, -2).Address(0, 0) & ">0"

    aRng.FormatConditions(aRng.FormatConditions.Count).SetFirstPriority

    With aRng.FormatConditions(1).Font

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

    End With

    With aRng.FormatConditions(1).Interior

        .Pattern = xlPatternLinearGradient

        .Gradient.Degree = 90

        .Gradient.ColorStops.Clear

    End With

    With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(0)

        .Color = 15773696

        .TintAndShade = 0

    End With

    With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(0.5)

        .ThemeColor = xlThemeColorDark1

        .TintAndShade = 0

    End With

    With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(1)

        .Color = 15773696

        .TintAndShade = 0

    End With

    aRng.FormatConditions(1).StopIfTrue = False

End Sub

purtroppo non lo riesco ad adattare in queste due sub (identiche per comodità):

Public Sub DOPPIE()

Dim PulR1 As Shape

    Const rPul1 As String = "SR_1"

    With ActiveSheet

        Set PulR1 = .Shapes(rPul1)

    End With

    With PulR1

            .Fill.ForeColor.RGB = RGB(244, 176, 132) ‘ <- da modificare

    End With

End Sub

nella suddetta Sub dovrei avere il seguente colore di sfondo:

mentre in quest'altra Sub:

Public Sub TRIPLE()

Dim PulR1 As Shape

    Const rPul1 As String = "SR_1"

    With ActiveSheet

        Set PulR1 = .Shapes(rPul1)

    End With

    With PulR1

            .Fill.ForeColor.RGB = RGB(244, 176, 132) ‘ <- da modificare

    End With

End Sub

dovrei avere il seguente colore di sfondo:

Vladimiro

Microsoft 365 e Office | Excel | Per la casa | Windows

Domanda bloccata. Questa domanda è stata eseguita dalla community del supporto tecnico Microsoft. È possibile votare se è utile, ma non è possibile aggiungere commenti o risposte o seguire la domanda.

0 commenti

Risposta accettata dall'autore della domanda

Anonimo
2020-03-31T10:33:07+00:00

Ciao Vladimiro,

naturalmente va bene (ho modificato solo il codice da orizzontale a verticale .TwoColorGradient msoGradientVertical, 1).

Bene!

Ascolta, è da tempo che volevo chiedertelo: come mai le demo che metti on line sono senza pulsanti?

Per caso vengono cancellati nel momento del download?

Purtroppo Microsoft OneDrive cancella tutti i pulsanti. Per preservare i pulsanti nei file che carichi, potresti sfruttare DropBox anziché OneDrive.

===

Regards,

Norman

La risposta è stata utile?

1 persona ha trovato utile questa risposta.
0 commenti

Risposta accettata dall'autore della domanda

Anonimo
2020-03-30T18:36:56+00:00

Ciao Vladimiro,

Ciao,

ho preso spunto da un suggerimento di Norman per avere nelle celle il colore di sfondo sfumato:

Option Explicit

Public rCell As Range

Sub SetFormat(aRng As Range)

    Set rCell = Selection

    With Application

        .ScreenUpdating = False

        .EnableEvents = False

    End With

    aRng.Select

    Application.EnableEvents = True

    aRng.FormatConditions.Add Type:=xlExpression, Formula1:= _

                              "=" & aRng.Offset(0, -2).Address(0, 0) & ">0"

    aRng.FormatConditions(aRng.FormatConditions.Count).SetFirstPriority

    With aRng.FormatConditions(1).Font

        .ThemeColor = xlThemeColorLight1

        .TintAndShade = 0

    End With

    With aRng.FormatConditions(1).Interior

        .Pattern = xlPatternLinearGradient

        .Gradient.Degree = 90

        .Gradient.ColorStops.Clear

    End With

    With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(0)

        .Color = 15773696

        .TintAndShade = 0

    End With

    With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(0.5)

        .ThemeColor = xlThemeColorDark1

        .TintAndShade = 0

    End With

    With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(1)

        .Color = 15773696

        .TintAndShade = 0

    End With

    aRng.FormatConditions(1).StopIfTrue = False

End Sub

purtroppo non lo riesco ad adattare in queste due sub (identiche per comodità):

Public Sub DOPPIE()

Dim PulR1 As Shape

    Const rPul1 As String = "SR_1"

    With ActiveSheet

        Set PulR1 = .Shapes(rPul1)

    End With

    With PulR1

            .Fill.ForeColor.RGB = RGB(244, 176, 132) ‘ <- da modificare

    End With

End Sub

nella suddetta Sub dovrei avere il seguente colore di sfondo:

mentre in quest'altra Sub:

Public Sub TRIPLE()

Dim PulR1 As Shape

    Const rPul1 As String = "SR_1"

    With ActiveSheet

        Set PulR1 = .Shapes(rPul1)

    End With

    With PulR1

            .Fill.ForeColor.RGB = RGB(244, 176, 132) ‘ <- da modificare

    End With

End Sub

dovrei avere il seguente colore di sfondo:

Vladimiro

Se ho capito bene, prova qualcosa del genere:

'=========>>

Option Explicit

'--------->>

Public Sub Demo1()

    With ActiveSheet.Shapes("Rectangle 1").Fill        '<<=== Modifica

        .Visible = msoTrue

        .ForeColor.RGB = RGB(243, 175, 32)

        .BackColor.RGB = RGB(254, 218, 101)

        .TwoColorGradient msoGradientHorizontal, 1

        .RotateWithObject = msoTrue

    End With

End Sub

'--------->>

Public Sub Demo2()

    With ActiveSheet.Shapes("Rectangle 2").Fill       '<<=== Modifica

        .Visible = msoTrue

        .ForeColor.RGB = RGB(168, 207, 143)

        .BackColor.RGB = RGB(253, 216, 101)

        .TwoColorGradient msoGradientHorizontal, 1

        .RotateWithObject = msoTrue

    End With

End Sub

'<<=========

Potresti scaricare il mio file di prova Vladimiro2_20200330.xlsm

===

Regards,

Norman

La risposta è stata utile?

0 commenti

2 risposte aggiuntive

Ordina per: Più utili
Più utili Più recente Meno recente
  1. Anonimo
    2020-03-31T11:19:58+00:00

    Ciao Vladimiro,

    naturalmente va bene (ho modificato solo il codice da orizzontale a verticale .TwoColorGradient msoGradientVertical, 1).

    Bene!

    Ascolta, è da tempo che volevo chiedertelo: come mai le demo che metti on line sono senza pulsanti?

    Per caso vengono cancellati nel momento del download?

    Purtroppo Microsoft OneDrive cancella tutti i pulsanti. Per preservare i pulsanti nei file che carichi, potresti sfruttare DropBox anziché OneDrive.

    ===

    Regards,

    Norman

    Ciao Norman,

    ok grazie e alla prossima.

    Vladimiro

    La risposta è stata utile?

    0 commenti
  2. Anonimo
    2020-03-30T19:08:32+00:00

    Ciao Vladimiro,

    Ciao,

    ho preso spunto da un suggerimento di Norman per avere nelle celle il colore di sfondo sfumato:

    Option Explicit

    Public rCell As Range

    Sub SetFormat(aRng As Range)

        Set rCell = Selection

        With Application

            .ScreenUpdating = False

            .EnableEvents = False

        End With

        aRng.Select

        Application.EnableEvents = True

        aRng.FormatConditions.Add Type:=xlExpression, Formula1:= _

                                  "=" & aRng.Offset(0, -2).Address(0, 0) & ">0"

        aRng.FormatConditions(aRng.FormatConditions.Count).SetFirstPriority

        With aRng.FormatConditions(1).Font

            .ThemeColor = xlThemeColorLight1

            .TintAndShade = 0

        End With

        With aRng.FormatConditions(1).Interior

            .Pattern = xlPatternLinearGradient

            .Gradient.Degree = 90

            .Gradient.ColorStops.Clear

        End With

        With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(0)

            .Color = 15773696

            .TintAndShade = 0

        End With

        With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(0.5)

            .ThemeColor = xlThemeColorDark1

            .TintAndShade = 0

        End With

        With aRng.FormatConditions(1).Interior.Gradient.ColorStops.Add(1)

            .Color = 15773696

            .TintAndShade = 0

        End With

        aRng.FormatConditions(1).StopIfTrue = False

    End Sub

    purtroppo non lo riesco ad adattare in queste due sub (identiche per comodità):

    Public Sub DOPPIE()

    Dim PulR1 As Shape

        Const rPul1 As String = "SR_1"

        With ActiveSheet

            Set PulR1 = .Shapes(rPul1)

        End With

        With PulR1

                .Fill.ForeColor.RGB = RGB(244, 176, 132) ‘ <- da modificare

        End With

    End Sub

    nella suddetta Sub dovrei avere il seguente colore di sfondo:

    mentre in quest'altra Sub:

    Public Sub TRIPLE()

    Dim PulR1 As Shape

        Const rPul1 As String = "SR_1"

        With ActiveSheet

            Set PulR1 = .Shapes(rPul1)

        End With

        With PulR1

                .Fill.ForeColor.RGB = RGB(244, 176, 132) ‘ <- da modificare

        End With

    End Sub

    dovrei avere il seguente colore di sfondo:

    Vladimiro

    Se ho capito bene, prova qualcosa del genere:

    '=========>>

    Option Explicit

    '--------->>

    Public Sub Demo1()

        With ActiveSheet.Shapes("Rectangle 1").Fill        '<<=== Modifica

            .Visible = msoTrue

            .ForeColor.RGB = RGB(243, 175, 32)

            .BackColor.RGB = RGB(254, 218, 101)

            .TwoColorGradient msoGradientHorizontal, 1

            .RotateWithObject = msoTrue

        End With

    End Sub

    '--------->>

    Public Sub Demo2()

        With ActiveSheet.Shapes("Rectangle 2").Fill       '<<=== Modifica

            .Visible = msoTrue

            .ForeColor.RGB = RGB(168, 207, 143)

            .BackColor.RGB = RGB(253, 216, 101)

            .TwoColorGradient msoGradientHorizontal, 1

            .RotateWithObject = msoTrue

        End With

    End Sub

    '<<=========

    Potresti scaricare il mio file di prova Vladimiro2_20200330.xlsm

    ===

    Regards,

    Norman

    Ciao Norman,

    naturalmente va bene (ho modificato solo il codice da orizzontale a verticale .TwoColorGradient msoGradientVertical, 1).

    Ascolta, è da tempo che volevo chiedertelo: come mai le demo che metti on line sono senza pulsanti?

    Per caso vengono cancellati nel momento del download?

    Vladimiro

    La risposta è stata utile?

    0 commenti