Formattazione condizionale solo sulle date

[fantina]

Ciao!!

tempo fa mi avevate suggerito questa splendida soluzione per evidenziare solo le parole di un determinato vocabolario. Oggi avrei bisogno di chiedervi un aiuto per evidenziare invece solo la data che viene scritta così 18/9 (e/o 19/9 e/o 20/9...eccetera, la cella contiene un riassunto di determinati eventi durati nel tempo quindi queste compaiono contemporaneamente all'interno della medesima cella); mi basterebbe poterle trasformare in grassetto ma non essendo come nell'altro caso un range di poche variabili non saprei come modificare la macro: si può fare?

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myArea As String, myWords, myBold, myColors, myUnderl, mySize, myTarget
Dim myF, I As Long
'
myArea = "B1:B100"      '<<< L' area in cui sara' effettuata la ricerca
'
If Application.Intersect(Target, Range(myArea)) Is Nothing Then Exit Sub
If Target.Count <> 1 Then Exit Sub
If IsError(Target.Value) Then Exit Sub
'
myTarget = Replace(Replace(Replace(Target.Value, ",", " "), ".", " "), "?", " ") & " "
Application.EnableEvents = False
'il mio dizionario di Parole, Grassetto, Sottolineato, Colore
myWords = Array("Rimpatriato", "Dimesso", "terza")
myBold = Array(1, 0, 1)     '1=Si, 0=No
myUnderl = Array(0, 1, 0)   'idem
mySize = Array(0, 14, 0)    '0=default, >0=imposta
myColors = Array(RGB(255, 0, 0), RGB(0, 255, 0), RGB(255, 255, 0))
'
'Ripristina formati:
Target.Font.FontStyle = "Normale"               '<*
Target.Font.ColorIndex = xlAutomatic            '<*
Target.Font.Underline = xlUnderlineStyleNone    '<*
Target.Font.Size = Application.StandardFontSize '<*
'
'Ricerca e modifica:
For I = LBound(myWords, 1) To UBound(myWords, 1)
    myF = InStr(1, myTarget, (myWords(I) & " "), vbTextCompare)
    If myF > 0 Then
        With Target.Characters(Start:=myF, Length:=Len(myWords(I))).Font
            .Bold = myBold(I)
            .Color = myColors(I)
            If myUnderl(I) = 0 Then .Underline = xlUnderlineStyleNone Else .Underline = xlUnderlineStyleSingle
            If mySize(I) > 0 Then .Size = mySize(I)
        End With
    End If
Next I
'
Application.EnableEvents = True
End Sub

[Anthony47]

Prova con questa macro

Codice: Seleziona tutto

Sub markdate()
Dim Neutri As String, I As Long, myRVal As String, J As Long
Dim myStart As Long, mySplit, myCol As String
'
myCol = "b"             '<<< La colonna con le scritte da riga 2
'
Neutri = "',.;:?!&()""|^-_+*#@<>" & Chr(10) & Chr(13) & Chr(9)  'Caratteri da neutralizzare
'
For I = 2 To Cells(Rows.Count, myCol).End(xlUp).Row
    myRVal = Cells(I, myCol).Value & " "
    Cells(I, myCol).Font.ColorIndex = xlAutomatic '<*
    Cells(I, myCol).Font.Bold = False '<*
    For J = 1 To Len(Neutri)
        myRVal = Replace(myRVal, Mid(Neutri, J, 1), " ", , , vbTextCompare)
    Next J
    mySplit = Split(myRVal, " ", , vbTextCompare)
    myStart = 1
    For J = 0 To UBound(mySplit, 1)
        If IsDate(mySplit(J)) Then
            With Cells(I, myCol).Characters(Start:=myStart, Length:=Len(mySplit(J))).Font
                .Bold = True
                .Color = RGB(255, 0, 0)
            End With
        End If
        myStart = myStart + Len(mySplit(J)) + 1
    Next J
Next I
End Sub


Devi personalizzare la riga marcata <<<, con la colonna contenente le scritte.
Mette le "presunte date" in grassetto + rosso; dico "presunte" perche' mancando l'anno non e' possibile identificare con certezza se una stringa sia veramente una data.

Ciao

[fantina]

non funge
ho cambiato il nome della colonna che è la r ma niente
...

[Anthony47]

Vuoi dire che la macro gira ma non combina un bel niente, vero?
Per caso sono dati importati da un web server?
Comunque prova a modificare questa riga:

Codice: Seleziona tutto

Neutri = "',.;:?!&()""|^-_+*#@<>" & Chr(10) & Chr(13) & Chr(9)  & Chr(160)      'Caratteri da neutralizzare


(togli la precedente e metti questa)
Ma se non risolve allora mi serviranno un paio di righe di testo per capire cosa c'e' dentro, inviate tramite un file txt.

Ciao

[fantina]

Buongiorno Anthony, posso inviarti un esempio qui? dato che si tratta di un normalissimo testo digitato manualmente nella casella "Note" del database dove registriamo gli eventi. Per esempio la cella potrebbe contenere:
15/9 Disembarked 16/9 Called guest mobile off 18/9 Called insurance company 20/9 repatriated
detto succintamente, tutto nella stessa cella.
Purtroppo non funziona neanche con la modifica
Grazie!

[Anthony47]

Credo che si sia un equivoco: la macro che ti ho proposto deve essere avviata a mano per sortire l'effetto, mentre probabilmente tu ti aspetti che le modifiche siano apportate in realtime man mano che le righe vengono compilate.
Se e' cosi', allora dobbiamo modificare il codice per inserirlo in una macro di WorksheetChange.

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Neutri As String, I As Long, myRVal As String, J As Long
Dim myStart As Long, mySplit, myCol As String, myCell As Range
'
myCol = "R"             '<<< La colonna con le scritte
'
Neutri = "',.;:?!&()""|^-_+*#@<>" & Chr(10) & Chr(13) & Chr(9) & Chr(160)   'Caratteri da neutralizzare
'
For Each myCell In Target
If myCell.Column = Range(myCol & 1).Column Then
    myRVal = myCell.Value & " "
    myCell.Font.ColorIndex = xlAutomatic '<*
    myCell.Font.Bold = False '<*
    For J = 1 To Len(Neutri)
        myRVal = Replace(myRVal, Mid(Neutri, J, 1), " ", , , vbTextCompare)
    Next J
    mySplit = Split(myRVal, " ", , vbTextCompare)
    myStart = 1
    For J = 0 To UBound(mySplit, 1)
        If IsDate(mySplit(J)) Then
            With myCell.Characters(Start:=myStart, Length:=Len(mySplit(J))).Font
                .Bold = True
                .Color = RGB(255, 0, 0)
            End With
        End If
        myStart = myStart + Len(mySplit(J)) + 1
    Next J
End If
Next myCell
End Sub


Trattandosi di una WorksheetChange va messa nel "modulo di codice" del foglio su cui si lavora:
-tasto dx sul tab col nome del foglio contenente i tuoi elenchi; scegli Visualizza codice; ti si apre l' editor delle macro; copia il codice e incollalo nel frame di dx; adatta le istruzioni marcate <<.

L'altra macro tienila come e', ti potra' servire nel caso che devi trattare un elenco gia' compilato.

Ciao

[fantina]

Buongiorno Anthony, in effetti non avevo specificato, questa ultima macro funziona benissimo e ti ringrazio.
Ho provato a far girare prima quell'altra per aggiornare le righe precedenti ma probabilmente ci sono troppi dati (oltre che il mio pc lascia un po' a desiderare) e l'operazione è lunga e non arriva alla fine...
Comunque ho raggiunto il mio scopo, grazie infinite come sempre! Ciao!