Evidenziare valori >0 disposti in riga e su tre colonne attigue.

[gianca53Partecipante gianca53]

Ciao, sempre per un mio progetto mi sono impantanato su una macro che sembra corretta e lineare ma non fa quello che le richiedo , e non capisco dove sbaglio. 

Allora,  in una tabella di dati azionari ho tre colonne F,G,H nelle quali vengono riportate le performance del titolo , ora vorrei evidenziare le celle tra loro attigue solo a condizione che Tutti i valori siano > di zero, cioè positivi. 

il codice che ho improvvisato non dà errore, ma non funziona, è il seguente : 

Sub EvidenziaSeriePositiva()    ' su tre specifiche colonne
    Dim ws As Worksheet
    Dim UltimaRiga As Long
    Dim Riga As Long
    Dim Col As Long
    Const ColInizio As Long = 6    ' Colonna F
    Const ColFine As Long = 8    ' Colonna H

    Set ws = ThisWorkbook.Sheets("Azioni")    '
    UltimaRiga = ws.Cells(ws.Rows.Count, ColInizio).End(xlUp).Row

    Application.EnableEvents = False
    Riga = 2: Col = 6

    For Riga = 2 To UltimaRiga

        For Col = ColInizio To ColFine

            ' Controlla se tutti valori sono > di 0 (positivi)
            If ws.Cells(Riga, Col).Value > 0 And ws.Cells(Riga, Col + 1).Value > 0 And ws.Cells(Riga, Col + 2) > 0 Then
                ws.Range(Cells(Riga, ColInizio), Cells(Riga, ColFine)).Interior.ColorIndex = 6

            Else
                ' Rimuovi il colore se non è una serie tutta  positiva
                ws.Range(Cells(Riga, ColInizio), Cells(Riga, ColFine)).Interior.ColorIndex = xlNone
            End If
        Next Col
    Next Riga
    Application.EnableEvents = True

    Set ws = Nothing
End Sub

 Allego anche immagine del risultato atteso. 

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

Elimina il >>>For Col = ColInizio To ColFine
Attualmente va in prima riga, il secondo For esegue il confronto in F/G/H e dopo in G/H/I e dopo in H/I/G
Poi nella seconda riga, ricomincia..

[gianca53Partecipante gianca53]

Grazie Raffaele, ma non funzia . Con o senza il For Col etc   mi colora tutta l'area interessata e non solo le celle contigue >0.

Stavo pensando di cambiare metodo ,ovvero fare la ricerca celle x cella di valori > 0 e solo alla fine rimuovere il colore tra celle non contigue se diversamente colorate ( bianco e Giallo) . 

P.s Ho provato con questa semplice macro ma ANCHE questa  questa colora tutte le celle anche le negative.  non è che ho un qualche settaggio di excel errato ? Tra l'altro avendo Office 2019 ogni volta che apro excel mi compare un messaggio di aggiornare Office poichè  questa mia versione è scaduta il 31/12/2025 

Sub coloraPositivo()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim rng As Range
    Dim cell As Range
    Dim UltimaR As Long    '
     UltimaR = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

    Set rng = ws.Range("F2:H" & UltimaR)
    For Each cell In rng
        If cell.Value > 0 Then
            cell.Interior.Color = vbYellow
        End If
    Next cell
End Sub

[scossaPartecipante scossa Karma: 37 pts]

gianca53 ha scritto:

 Allego anche immagine del risultato atteso

Con le immagini non ci si può lavorare: allega un file semplificato, coerente con l'originale.

P.S.: ma perché non usi la formattazione condizionale?

regola:: =($F2>0)*($G2>0)*($H2>0)

si applica a =$F$2:$H$nn dove nn sarà il numero di righe della tua tabella.

[albatros54Moderatore albatros54 Karma: 89 pts]

or Col = ColInizio To ColFine

            ' Controlla se tutti valori sono > di 0 (positivi)
            If (ws.Cells(Riga, Col).Value > 0) And (ws.Cells(Riga, Col + 1).Value > 0 )And (ws.Cells(Riga, Col + 2) > 0) Then
                ws.Range(Cells(Riga, ColInizio), Cells(Riga, ColFine)).Interior.ColorIndex = 6

            Else

prova a modificare la formula cosi

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

>>>a condizione che Tutti i valori siano > di zero
Come detto elimina >>>For Col = ColInizio To ColFine...
Però noto un particolare sui numeri positivi col segno "+" presente. Quelli sono numeri?

Ps. ws.Range(ws,Cells(x,y), ws.Cells(x,y))

Allegati:

You must be logged in to view attached files.

[gianca53Partecipante gianca53]

Albatros54,

provato ma non cambia nulla.

Scossa,  il problema è che questa pagina viene azzerata e riceve dati da un'altra macro che li importa via web. 

Allego file Test 

Allegati:

You must be logged in to view attached files.

[Raffaele53Partecipante Raffaele53 Karma: 23 pts]

La colonna G/H sono numeri formattati testo, pertanto

If ws.Cells(Riga, Col).Value*1 > 0 And ws.Cells(Riga, Col + 1).Value*1 > 0 And ws.Cells(Riga, Col + 2)*1 > 0 Then

[albatros54Moderatore albatros54 Karma: 89 pts]

prova cosi

`Sub EvidenziaSeriePositiva()    ' su tre specifiche colonne
    Dim ws As Worksheet
    Dim UltimaRiga As Long
    Dim Riga As Long
    Dim Col As Long
    Const ColInizio As Long = 6    ' Colonna F
    Const ColFine As Long = 8    ' Colonna H

    Set ws = ThisWorkbook.Sheets("Azioni")    '
    UltimaRiga = ws.Cells(ws.Rows.Count, ColInizio).End(xlUp).Row

    Application.EnableEvents = False
    Riga = 2: 'Col = 6

    For Riga = 2 To UltimaRiga

       ' For Col = ColInizio To ColFine

            ' Controlla se tutti valori sono > di 0 (positivi)
            If Val(ws.Cells(Riga, 6).Value) > 0 And Val(ws.Cells(Riga, 7).Value) > 0 And Val(ws.Cells(Riga, 8)) > 0 Then
                ws.Range(Cells(Riga, ColInizio), Cells(Riga, ColFine)).Interior.ColorIndex = 6

            Else
                ' Rimuovi il colore se non è una serie tutta  positiva
                ws.Range(Cells(Riga, ColInizio), Cells(Riga, ColFine)).Interior.ColorIndex = xlNone
            End If
             
        'Next Col
   Next Riga
    Application.EnableEvents = True

    Set ws = Nothing
End Sub`

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[gianca53Partecipante gianca53]

Grazie anche a @Raffele, grazie alla sua segnalazione ho visto che la  macro principale di scarico dati aveva un comportamento errato , in pratica mi dava numeri decimali col punto e numeri come stringa con la virgola. Un pasticcio insomma . 

 

 Un'altra cosa da capire, anche se non determinante, è perchè nel file Test mi dà il colore giallo (corretto) mentre integrata nel file ultimo il colore cambia a verde ? 

[scossaPartecipante scossa Karma: 37 pts]

Secondo me puoi risparmiare l'Else e un ciclo For .. Next (NB: semplificato ulteriormente il codice):

Sub EvidenziaSeriePositiva()    ' su tre specifiche colonne
    Dim ws As Worksheet
    Dim rng As Range, rRow As Range
    Dim UltimaRiga As Long
    Const ColInizio As Long = 6    ' Colonna F
    Const ColFine As Long = 8    ' Colonna H

    Set ws = ThisWorkbook.Sheets("Azioni")
    With ws
      UltimaRiga = .Cells(ws.Rows.Count, ColInizio).End(xlUp).Row
      Set rng = .Range(Cells(2, ColInizio), Cells(UltimaRiga, ColFine))
      Application.EnableEvents = False
  
      rng.Interior.ColorIndex = xlNone
      For Each rRow In rng.Rows
        If rRow.Cells(1, 1) > 0 And rRow.Cells(1, 2) > 0 And rRow.Cells(1, 3) > 0 Then 
          rRow.Interior.ColorIndex = 6
        End if
      Next rRow
      Application.EnableEvents = True
    End With
    Set ws = Nothing
End Sub

[gianca53Partecipante gianca53]

@scossa, grazie ,ma colora tutto l'intervallo .

[LukeRedsPartecipante LukeReds Karma: 19 pts]

ciao

è sufficiente questa formula da inserire in formattazione condizionale, selezion F2:Hn (n anche maggiore del numero di titoli presenti)

=E(1*$F2>0;1*$G2>0;1*$H2>0)

con vba

 

Sub ColoraRigaPos()
Dim n As Integer, r As Integer, c As Integer
n = Range("A" & Rows.Count).End(xlUp).Row
For r = 2 To n
   If 1 * Cells(r, 6) > 0 And 1 * Replace(Cells(r, 7), "%", "") > 0 And 1 * Replace(Cells(r, 8), "%", "")    > 0 Then
      Range("F" & r & ":H" & r).Interior.Color = vbYellow
   End If
Next r
End Sub

[scossaPartecipante scossa Karma: 37 pts]

gianca53 ha scritto:

@scossa, grazie ,ma colora tutto l'intervallo .

assolutamente no, se correggi i valori nel file che hai allegato

gianca53 ha scritto:

ho visto che la  macro principale di scarico dati aveva un comportamento errato , in pratica mi dava numeri decimali col punto e numeri come stringa con la virgola.

ma li hai corretti? ma soprattutto hai corretto la macro che scarica i dati?

[gianca53Partecipante gianca53]

@scossa, si hai ragione , tutto sto pasticcio viene creato da come la macro principale scarica i dati nelle tre colonne (FGH) e francamente non ne sono venuto a capo , quindi pubblico la macro incriminata e il file  Test2. 

P.s ore 11,20 ho aggiornato sia il codice che il file 

Allegati:

You must be logged in to view attached files.

[LukeRedsPartecipante LukeReds Karma: 19 pts]

hai provaro anche le altre soluzioni proposte?

[gianca53Partecipante gianca53]

Si, scusa la dimenticanza , anche la tua versione funziona perfettamente con i dati cosi come li ho pubblicati  con il % e il +  mentre quella di Scossa e anche la mia iniziale funzionano altrettanto bene  correggendo /riscrivendo i numeri , ovvero senza % e senza +.

[scossaPartecipante scossa Karma: 37 pts]

gianca53 ha scritto:

tutto sto pasticcio viene creato da come la macro principale scarica i dati nelle tre colonne (FGH) e francamente non ne sono venuto a capo

Spero che il codice della sub Azioni() non sia stato scrittto  da Borsa Italiana     

Intanto ripropongo il mio codice con la modifica che "interpreta" (non corregge) i valori stringa in numeri e quindi evidenzia correttamente le tre celle:

Sub EvidenziaSeriePositiva()    ' su tre specifiche colonne
    Dim ws As Worksheet
    Dim rng As Range, rRow As Range
    Dim UltimaRiga As Long
    Const ColInizio As Long = 6    ' Colonna F
    Const ColFine As Long = 8    ' Colonna H

    Set ws = ThisWorkbook.Sheets("Azioni")
    With ws
      UltimaRiga = .Cells(ws.Rows.Count, ColInizio).End(xlUp).Row
      Set rng = .Range(Cells(2, ColInizio), Cells(UltimaRiga, ColFine))
      Application.EnableEvents = False
  
      rng.Interior.ColorIndex = xlNone
      For Each rRow In rng.Rows
        If --Replace(rRow.Cells(1, 1), "%", "") > 0 And --Replace(rRow.Cells(1, 2), "%", "") > 0 And --Replace(rRow.Cells(1, 3), "%", "") > 0 Then
          rRow.Interior.ColorIndex = 6
        End If
      Next rRow
      Application.EnableEvents = True
    End With
    Set ws = Nothing
End Sub

 

[LukeRedsPartecipante LukeReds Karma: 19 pts]

il codice che ho postato sopra funziona anche senza % e  +, ad ogni modo non è più semplice usare la formattazione condizionale?

[gianca53Partecipante gianca53]

Qui il codice del file test2 :

Option Explicit
Public Sub Azioni()    'by Borsa Italiana

    Dim html As MSHTML.HTMLDocument
    Dim Isin As String
    Dim CollA As Object
    Dim n As Long, i As Integer

    Dim dati1 As Variant
    Dim intest As Variant
    Dim MyIsin As String
    Dim ur As Long, ii As Long
    Dim r

    ' Estrai i dati tutti i titoli <h1>
    Dim dataElements As Object
    Dim xi As Integer

    Dim Ws1 As Worksheet
    Set Ws1 = Sheets("Azioni")
    Ws1.Select
    Ws1.Activate


    'Call eliminaRigheVuote_Duplicati
    '
    ur = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Ws1.Range("B2:I" & ur).Clear
    ' codifica come stringa
    Set Ws1 = Sheets("Azioni")
    Ws1.Select
    Ws1.Activate

    ' Application.ScreenUpdating = False
    Application.EnableEvents = False

    intest = Array("Isin", "Ticker", "Ultimo", "Variazione % ", "Lotto", "Perform. 1 mese %", "Perform.6 mesi %", "Perform. 1 anno %", "Denominazione")    ' la scadenza trovasi sulla scheda Dati completi "Scadenza", Come ci arrivo ???
    Range("A1:I1") = intest
    ur = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
    Ws1.Range("B2:I" & ur).Clear
    
    ' -----------------------codifica come stringa -------------------------------------------
    With Ws1
        .Range("C2:H" & ur).NumberFormat = "@"

        '-----------------------controlla Isin --------------------------------------------------

        For ii = 2 To ur
            Isin = Trim$(UCase$(Cells(ii, 1).Text))
            If Isin Like "[A-Z][A-Z]?????????#" Then  ' controlla prime due sono lettere poi 10 tra lettere o numeri
                Cells(ii, 1) = Isin
            Else
                Cells(ii, 1).Select
                MsgBox "           Codice ISIN errato    !!!             "
            End If
        Next

        ' --------------converti isin a maiuscolo-------------------------------
        Dim X As Object
        For Each X In Range("A2:A" & ur)
            X.Value = UCase(X.Value)
        Next

        '----------------------------------->>>>>>>Preleva dati >>>>>>>>>---------------------------
        Set html = CreateObject("htmlfile")

        With CreateObject("WINHTTP.WinHTTPRequest.5.1")

            For n = 2 To ur
                MyIsin = Cells(n, 1)
                If MyIsin <> "" Then

                    .Open "GET", "https://www.borsaitaliana.it/borsa/azioni/dati-completi.html?isin=" & MyIsin & "&lang=it"
                    .send
                    html.body.innerHTML = .responseText
                    Application.Wait Now + TimeValue("00:00:01")    'pausa di 1 secondi
                    On Error Resume Next


                    Set CollA = html.getElementsByClassName("t-text -right")
                    Set dataElements = html.getElementsByTagName("h1")
                    On Error GoTo 0

                    If Not CollA Is Nothing Then
                        If CollA.Length > 5 Then    '+++
                            On Error Resume Next

                            dati1 = Array(0, 1, 3, 9, 10, 7, 25, 26, 27)
                            For i = 2 To 8
                                For xi = 0 To dataElements.Length - 1
                                    Cells(n, i) = CollA(dati1(i)).innerText
                                    Cells(n, 9) = dataElements(xi).innerText
                                Next xi
                            Next i

                            On Error GoTo 0

                        End If
                    End If

                End If


            Next n
        End With
    End With


    ' --------------------converte testo a numero--------------------------------
    For Each r In Sheets("Azioni").UsedRange.SpecialCells(xlCellTypeConstants)
        If IsNumeric(r) Then
            r.Value = CSng(r.Value)
            r.NumberFormat = "0.00"
        End If
    Next
    '
    Range("C2:D" & ur).NumberFormat = "#,##0.00"
    Range("F2:f" & ur).NumberFormat = "0.00"

    Range("C2:H" & ur).Select
    With Selection
        .HorizontalAlignment = xlRight
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Range("a1").Select

    ' Application.ScreenUpdating = True
    Application.EnableEvents = True
    Set Ws1 = Nothing
    Set CollA = Nothing
    Set dataElements = Nothing
    Set html = Nothing
End Sub

[LukeRedsPartecipante LukeReds Karma: 19 pts]

devi scaricare tutto il listino A:Z? In caso.. da abilitare le librerie nell'immagine (forse ce n'è una una che non serve), codice da affinare in caso serva

 

`Sub titoliX()
Dim XMLReq As New MSXML2.XMLHTTP60
Dim doc As New MSHTML.HTMLDocument
Dim elems As MSHTML.IHTMLElementCollection
Dim elem As MSHTML.IHTMLElement, Dels As MSHTML.IHTMLElementCollection
Dim tr As MSHTML.IHTMLElement, td As MSHTML.IHTMLElement, a As MSHTML.IHTMLElement
Dim r As Integer, c As Integer, i As Integer, sitow As String
r = 1
Cells.Clear
For i = 65 To 90
   sitow = "https://www.borsaitaliana.it/borsa/azioni/listino-a-z.html?initial=" & Chr(i) & "&lang=it"
   XMLReq.Open "GET", sitow, False
   XMLReq.send
   doc.body.innerHTML = XMLReq.responseText
   Set elem = doc.getElementsByTagName("tbody")(0)
   c = 1
   For Each tr In elem.getElementsByTagName("tr")
      If tr.className = "u-hidden -xs" Then
         For Each td In tr.getElementsByTagName("th")
            Cells(r, c) = td.innerText
            c = c + 1
         Next td
      Else
         For Each td In tr.getElementsByTagName("td")
            If c = 1 Then
               Cells(r, c) = td.getElementsByTagName("a")(0).innerText
            Else
               Cells(r, c) = td.innerText
            End If
               c = c + 1
         Next td
      End If
      r = r + 1: c = 1
   Next tr
Next i
Cells.WrapText = False
MsgBox "fine elaborazione"
End Sub`

Allegati:

You must be logged in to view attached files.

[gianca53Partecipante gianca53]

@lukereds , No solo gli Isin di mio interesse .

 Si la formattazione condizionale , sarebbe la soluzione più semplice, ma non in una pagina dinamica soggetta a cambiamenti per effetto della macro che scarica le quotazioni in tempo quasi reale . 

 

[gianca53Partecipante gianca53]

Spero che il codice della sub Azioni() non sia stato scrittto  da Borsa Italiana    

None , è opera mia . I tuoi sghei sono al sicuro...forse   

[gianca53Partecipante gianca53]

@lukereds , grazie, lo userò senz'altro .

[gianca53Partecipante gianca53]

Grazie a tutti.

[Autore]

Articoli