Quesito FC

[Raffaele53Partecipante Raffaele53 Karma: 21 pts]

Ciao a tutti, in colonna A ci sono dei nomi ed in colonna B ci sono dei valori da 1 a 1000.
Selezionando le celle B1:B100, tramite FC scelgo "Barra dei dati" vengono colorate parte delle celle in base al loro valore.
Volevo sapere se invece è possibile colorare la colonna A dei nomi per una visualizzazione-scelta migliore?

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao

Spero di essere smentito ma non credo si possa ottenere il medesimo risultato. Se imposti la regola con una formula basata sul valore della colonna B verrà colorata l'intera cella e non solo una parte.

Ciao,

Mario

[Raffaele53Partecipante Raffaele53 Karma: 21 pts]

@marius44, lo pensavo già. Grazie lo stesso

Trovato in rete, in pratica usa delle "forme" per colorare A1:A30. Mi sembra valido, devo valutare se opportuno.
Ps. Non riesco allegare il VBA, inserisco un TXT

Allegati:

You must be logged in to view attached files.

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao 

potrebbe essere la soluzione. Un mio suggerimentro potrebbe essere quello di evitare che il valore minimo non venga considerato (dalle mie prove al valore minimo non è associata alcuna shape).

Ciao,

Mario

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao

Dalle ultriori prove effettuate penso che la macro sottostante sia più aderente alle esigenze:

Sub Bars_pct() 'by Marius44
Dim rng As Range, rngV As Range, c As Range, mx As Double, mn As Double
Dim shp As Shape, nm As String, i As Long, v
    
Set rng = Sheets(1).Range("A2:A7")  '(eg) range with bars
Set rngV = rng.Offset(0, 3)         '(eg) range with values for the bars
mx = Application.Max(rngV)          'get values range max/min
mn = Application.Min(rngV)
'Stop
For i = 1 To rng.Cells.Count 'loop over the range where the bars need to be
  Set c = rng.Cells(i)
  nm = "databar" & c.Address(False, False)  'name for the shape
  Set shp = Nothing                         'clear any previous shape reference
  On Error Resume Next                      'ignore error if no bar
  Set shp = c.Parent.Shapes(nm)
  On Error GoTo 0                           'stop ignoring errors
  If shp Is Nothing Then                    'is there an existing bar?
    'no existing bar - add and format
    Set shp = c.Worksheet.Shapes.AddShape(msoShapeRectangle, _
              c.Left + 1, c.Top + 1, c.Width - 1, c.Height - 1)
    shp.Line.Visible = msoFalse
    With shp.Fill
      .Visible = msoTrue
      .ForeColor.RGB = RGB(100, 100, 250)
      .Transparency = 0.6
    End With
    shp.Name = nm
  End If
  'adjust the bar width according the the cell in the "values" range...
  v = rngV.Cells(i).Value
  'larghezza shp proporzionale alla larghezza della cella
  'ponendo il valore massimo pari alla larghezza della cella
  shp.Width = v / mx * c.Width
  If v >= 1 Then shp.Fill.ForeColor.RGB = RGB(0, 255, 0)
Next i
End Sub

In altre parole dà un colore diverso alle shapes a seconda se è stato raggiunto o meno il budget. In più la larghezza di ogni shape è proporzionale alla larghezza della colonna ed al valore massimo dei valori considerati.

Allego il file.

Ciao,

Mario 

Allegati:

You must be logged in to view attached files.

[Raffaele53Partecipante Raffaele53 Karma: 21 pts]

Ciao Marius44
In teoria per colorare la cella minima basta aggiungere un -1
>>>mn = Application.Min(rngV)-1

Sto trovando problemi ad eliminare shapes….
L'area A3:A100 contiene pure celle vuote, pertanto nel ciclo userò un IF cells(i,2) <> "" Then per inserire le shapes.
Il problema al prossimo Worksheet_Change, dovrebbe prima controllare se in B esiste un valore e casomai eliminare la shapes in A. Certo potrei eliminare tutte le shapes prima e dopo ricrearle tutte se occorre, mà preferirei conoscendo il nome
>>>nm = "databar" & C.Address(False, False) eliminare solo lei e non ci riesco. Grazie mille

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao Raffaele53

Potresti pubblicare, per favore, l'intero codice che utilizzi? e, possibilmente, anche il file nel quale hai il problema?

Ciao,

Mario

[Raffaele53Partecipante Raffaele53 Karma: 21 pts]

Ti ringrazio mà non posso. Sono riuscito ad eliminare le shapes-presenti in caso di modifiche nulle.
Premessa: In nomi sono in B3:B30, in F3:F30 gli anni ed in M3:M30 i valori con alcune celle vuote(le righe non variano mai). Il tutto condito dalla convalida-dati in cella Q31 che appena modificata varia il risultato delle formule ed avvia il codice visualizzando l'opzione migliore. Non riesco allegare il VBA, inserisco un TXT

Allegati:

You must be logged in to view attached files.

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao

Alcune cose che non capisco:

1) For i = 3 To rng.Cells.Count - questa riga di codice cicla fino alla riga 30 e non 33 (quale dovrebbe essere) . Penso dovrebbe essere meglio così: Cells(Rows.Count, "B").End(xlUp).Row

2) If Cells(i, "Q") <> "" Then - perchè fare riferimento alla colonna "Q" (che dovrebbe essere vuota tranne che in Q31 dove c'è la Convalida? Forse voleva essere "M"?

3) If Cells(i, "F") < 29 Then - cosa vuol dire <29? Salvo errore hai detto che in col.F ci sono gli anni. Li hai inseriti SOLO con due cifre oppure il valore è errato.?

Ciao,

Mario

[Raffaele53Partecipante Raffaele53 Karma: 21 pts]

Ciao Marius44

2) If Cells(i, "Q") <> "" Then. Giusto cosi in Q3:Q30 ci sono formule
3) If Cells(i, "F") < 29 Then. Gli anni sono effettivi ex nato nel 2000 = 25

1) For i = 3 To rng.Cells.Count. In effetti ho tentennato un po', oggi rifarei il tutto un semplice For X = 3 to 30
Ieri ho scelto tra ...
Range B1:B30
For i = 3 To rng.Cells.Count (le prime due non vanno elaborate. Tot=28)
If Cells(i, "F")
If Cells(i, "Q")
oppure
Range B3:B30
For i = 1 To rng.Cells.Count
If Cells(i + 2, "F")
If Cells(i + 2, "Q")

Naturalmente ci saranno altri modi per fare meglio.
Ps. Ho modificato mx = 1000 ed mn = 100 (sono i miei valori max & min ottimali) ed ho una visuale più chiara.

[Marius44Moderatore Marius44 Karma: 58 pts]

Ciao

Purtroppo non avendo il file sottomano (non potevo immaginare che in col.Q ci fossero delle formule) e tralasciando i miei errori nel ricostruire lo scenario, devo rinunciare. Non riesco ad immaginare l'obiettivo.

Ciao e scusa,

Mario

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Ma il thread e' risolto o no? A me sembra che tutto funzioni bene. Ho modificato lievemente il codice di Supermario ma tutto sembra ok

Cancellando un valore in M e inserendo qualcosa in Q31 si scatena l'evento Change del foglio (a proposito, ho cambiato leggermente anche il controllo sui fogli da coinvolgere, mi sembra meno complicato cosi').

 E poi: Option Explicit!! metterlo sempre. Per cancellare una shape basta ActiveSheet.Shapes(nm).Delete.

Allego un file.

Allegati:

You must be logged in to view attached files.

[Raffaele53Partecipante Raffaele53 Karma: 21 pts]

Vi ringrazio mà era già risolto, appena avrò tempo riscrivo il tutto.

@VF carino il tuo metodo per  elaborare solo determinati fogli.

[LukeRedsPartecipante LukeReds Karma: 13 pts]

ciao,

soluzione !spartana" ma molto semplice

1) larghezza delle prime 100 o 200 colonne = 0,2,

2) nomi in colonna A da A2, numeri in colonna U da U2

2) poi (nell'esempio arrivo fino alla 16a riga)

Sub FC()
Dim r As Integer, c As Integer, n As Integer
Range("A2:ZZ16").ClearFormats
For r = 2 To 16
n = Round(Cells(r, "u") / 10, 0)
   For c = 1 To n
      Cells(r, c).Interior.ColorIndex = 33
   Next c
Next r
End Sub

 

Allegati:

You must be logged in to view attached files.

[Autore]

Articoli