Attribute VB_Name = "evidenzia_ricerca_valori"
'
Option Explicit
'
' vba - Excel
' Evidenzia Valori Colonna Per Contenuto
' ricerca ed evidenzia cella in base al contenuto utilizzando una espressione regolare
' alternativa leggera alla formattazione condizionale
'
Sub uso_EvidenziaValoriColonnaPerContenuto()
'
Dim nomefoglio, colonnaricerca, datoricercato
Dim campi, ritorno
campi = Array("", "nome foglio", "colonna ricerca", "dato ricercato")
ritorno = creaMaskeraHtml(campi)
'
nomefoglio = ritorno(1)
colonnaricerca = ritorno(2)
datoricercato = ritorno(3)
'
Call EvidenziaValoriColonnaPerContenuto(nomefoglio, colonnaricerca, datoricercato)
'
End Sub
'
Sub EvidenziaValoriColonnaPerContenuto(nomefoglio, colonnaricerca, datoricercato)
Dim procedura, cella As Range, foglio, zonaricerca, quanterighe
Set foglio = Sheets(nomefoglio)
' conteggio righe utilizzate
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).row
'
Set zonaricerca = foglio.Range(Cells(1, colonnaricerca), Cells(quanterighe, colonnaricerca))
Set procedura = CreateObject("VBScript.RegExp")
'
With procedura
.Pattern = datoricercato
.IgnoreCase = True
.Global = True
For Each cella In zonaricerca
If .test(cella.Value) Then
cella.Interior.ColorIndex = 6
End If
Next cella
End With
'
Set procedura = Nothing
'
End Sub
'
Function creaMaskeraHtml(campi)
'
On Error GoTo esci
'
Dim txtHtml, IE, valoriinput, quanticampi, contacampi
quanticampi = UBound(campi)
ReDim ritorno(quanticampi)
ritorno(0) = "errore"
'
Set IE = CreateObject("InternetExplorer.Application")
IE.navigate "about:blank"
IE.Top = 150
IE.Visible = True
IE.Height = 300
IE.Width = 550
IE.MenuBar = False
IE.Toolbar = False
IE.StatusBar = False
IE.resizable = True
'
IE.document.Title = " - ricerca - "
' crea codice HTML della pagina per input dei valori.
' utilizzando una form e una tabella
txtHtml = ""
txtHtml = txtHtml + "<html><body><center>"
txtHtml = txtHtml + " inserimento<br>"
txtHtml = txtHtml + "<FORM name=""mask""><table>"
For contacampi = 1 To quanticampi
txtHtml = txtHtml + "<TR>" ' crea nuova riga
txtHtml = txtHtml + "<TD>" ' crea colonna della descrizione
txtHtml = txtHtml + campi(contacampi) ' testo visualizzato
txtHtml = txtHtml + ":</TD><TD>" ' nuova colonna
txtHtml = txtHtml + "<input name=""" & campi(contacampi) & """ type=""text"" value="""">" ' box input
txtHtml = txtHtml + "</TD></TR>"
Next contacampi
txtHtml = txtHtml + "</table></FORM></body></html>"
IE.document.body.innerHTML = txtHtml
'
' Do While IE.readyState = 4: DoEvents: Loop
'
Do While IE.readystate = 4
'
contacampi = 0
For Each valoriinput In IE.document.all.tags("INPUT")
contacampi = contacampi + 1
ritorno(contacampi) = valoriinput.Value
Next
'
DoEvents
Loop
'
ritorno(0) = "risposta"
Set IE = Nothing
'
esci:
'
creaMaskeraHtml = ritorno
'
End Function
'
'
Nessun commento:
Posta un commento