Come nuovo iscritto sto cercando di esplorare tutti i post possibili per comprendere il meccanismo delle macro, in particolare modo mi ha incuriosito una soluzione che riguarda la Formattazione condizionata con diversi stili, sulla base di più condizioni.
Il post in questione è il seguente: viewtopic.php?f=9&t=7325
Purtroppo, almeno con il mio PC, la macro risulta lentissima, per visualizzare il risultato bisognerebbe chiudere il file e riaprirlo.
A differenza della richiesta nel post, la mia esigenza sarebbe quella di rilevare i duplicati presenti in UNA sola colonna, senza alcun confronto con altre e allo stesso tempo formattare l'intera riga corrispondente (vedi allegato "foglio2"), sperando che in questo modo sia più veloce nell'esecuzione.
Ho provato a fare delle prove, ma alla cieca, in quanto non riesco / non conosco la modalità per eseguire il debug della macro.
Macro:
Codice: Seleziona tutto
'Option Explicit
Sub Formattazione()
Dim Doc As Object, c As Long, Sh As Object, Arr As New Collection, svc As Object
Dim ri As Long, rf As Long, ci As Long, cf As Long, Color As Long, Art As String
Dim InRange As Object, item As String
Doc = ThisComponent
Sh= Doc.Sheets.getbyName("Foglio1")
svc = createUnoService("com.sun.star.sheet.FunctionAccess")
InRange = Sh.getcellRangeByName("C4:D18")
InRange.CellBackColor = - 1
Addr = InRange.RangeAddress
ci = Addr.StartColumn
cf = Addr.EndColumn
ri = Addr.StartRow
rf = Addr.EndRow
On Error Resume Next
For c = ci To cf
For r = ri To rf
Art = Sh.getCellByPosition(c, r).String
Arr.Add Art, CStr(Art)
Next r
Next c
On Error Goto 0
Color = 16252663
For i = 1 To Arr.Count
For c = ci To cf
For r = ri To rf
item = Sh.getCellByPosition(c, r).String
If item = Arr(i) And svc.callFunction("COUNTIF", Array(InRange, item)) > 1 Then
if c = cf And Sh.getCellByPosition(c-1, r).CellBackColor <> -1 Then
Sh.getCellByPosition(c, r).CellBackColor = Sh.getCellByPosition(c-1, r).CellBackColor
else
Sh.getCellByPosition(c, r).CellBackColor = Color
End if
End if
Next r
Next c
Color = Color + 16252650
Next
Set Arr = Nothing
End SubAllego il file del post che vi parlavo dove è presente, nel "foglio2" la mia esigenza.
