giovedì 14 marzo 2013

evidenzia ricerca valori

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