Attribute VB_Name = "riconciliazione_cg_banca"
'
Option Explicit
'
' vba - Excel
' Riconciliazione movimenti Banca - Prima Nota
' ricerca ed evidenzia (in giallo) cella in base al contenuto utilizzando una espressione regolare
' le celle evidenziate non vengono più utilizzate per la ricerca
'
Dim rigatrovato
'
Sub RiconciliazionePrimaNotaBanca()
'
Dim nomefoglioprimanota, nomefogliobanca, colonnaprimanota, colonnabanca, datoricercato
Dim campi, ritorno
'
' input nome fogli e colonne per la ricerca
campi = Array("", "nome foglio prima nota", "colonna importi prima nota", "nome foglio banca", "colonna importi banca")
ritorno = creaMaskeraHtml(campi)
'
nomefoglioprimanota = ritorno(1)
colonnaprimanota = ritorno(2) ' colonna valori
nomefogliobanca = ritorno(3)
colonnabanca = ritorno(4) ' colonna valori
'
Dim quanterighe, contarighe, foglio
Set foglio = Sheets(nomefoglioprimanota)
'
' conteggio righe utilizzate
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).row
'
contarighe = 1
While contarighe <= quanterighe
datoricercato = foglio.Cells(contarighe, colonnaprimanota).Value
If IsNumeric(datoricercato) = True Then
If datoricercato > 0 Then
Call EvidenziaValoriColonnaPerContenuto(nomefogliobanca, colonnabanca, datoricercato)
If rigatrovato > 0 Then
foglio.Cells(contarighe, colonnaprimanota).Interior.ColorIndex = 6
End If
End If
End If
contarighe = contarighe + 1
Wend
'
'
End Sub
'
Function EvidenziaValoriColonnaPerContenuto(nomefoglio, colonnaricerca, datoricercato)
rigatrovato = 0
Dim procedura, cella As Range, foglio, zonaricerca, quanterighe, colorecella
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).Address, Cells(quanterighe, colonnaricerca).Address)
Set procedura = CreateObject("VBScript.RegExp")
'
With procedura
.Pattern = datoricercato
.IgnoreCase = True
.Global = True
For Each cella In zonaricerca
If .test(cella.Value) Then
colorecella = cella.Interior.ColorIndex ' verifica il colore cella
If colorecella = 6 Then ' nel caso il valore sia evidenziato
Else
cella.Interior.ColorIndex = 6 ' evidenzia la cella
rigatrovato = cella.row ' memorizza il numero riga
Exit Function
End If
End If
Next cella
End With
'
Set procedura = Nothing
'
End Function
'
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