Attribute VB_Name = "crea_rubrica_css_html"
'
Option Explicit
'
' vba - excel
' converte il foglio attivo in una pagina html
' scansiona tutte le righe del foglio
' alla tabella html viene viene formatta con css style
'
Sub CreaRubricaHtmlcss()
'
Dim txtcella, contarighe, quanterighe, riga, testo, fs, a, testotd
Dim quantecolonne, contacolonne, cartellap, nomefoglio, cartella, messaggio, foglio, tiporiga
nomefoglio = ActiveSheet.Name
Set foglio = Sheets(nomefoglio)
cartellap = "C:\"
cartella = cartellap & nomefoglio & ".html"
messaggio = ""
messaggio = "il nome della rubrica e': " & nomefoglio & vbCrLf
messaggio = messaggio & "(il mome del foglio attivo)" & vbCrLf
messaggio = messaggio & "cartella in cui sara' salvata la rubrica: " & vbCrLf
messaggio = messaggio & cartellap
MsgBox messaggio
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
Set a = fs.CreateTextFile(cartella, True)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column
'
testotd = "<TD>"
' intestazione
a.WriteLine ("<HTML><HEAD>")
a.WriteLine ("<TITLE>")
a.WriteLine (nomefoglio)
a.WriteLine ("</TITLE>")
' recupero codice html style
testo = memocodicecssstyle
a.WriteLine (testo)
'
a.WriteLine ("</HEAD>")
testo = "<BODY>"
a.WriteLine (testo)
a.WriteLine ("<CENTER><HR><BR> ")
a.WriteLine (nomefoglio)
a.WriteLine ("<HR> <Table id=""tabelladati"">")
' intestazione - utilizza la prima riga del foglio come intestazione
a.WriteLine ("<TR>")
For contacolonne = 1 To quantecolonne
txtcella = foglio.Cells(1, contacolonne).Value
testo = "<TH>" & txtcella & "</TH>"
a.WriteLine (testo)
Next contacolonne
a.WriteLine ("</TR>")
' scrive tutte le righe e colonne del foglio
For contarighe = 2 To quanterighe ' parte dalla seconda riga
tiporiga = contarighe Mod 2 ' determina quale style applicare
If tiporiga = 0 Then
testo = "<TR>"
Else
testo = "<TR class=""alt"">"
End If
a.WriteLine (testo)
For contacolonne = 1 To quantecolonne
txtcella = foglio.Cells(contarighe, contacolonne).Value
testo = testotd & txtcella & "</TD>"
a.WriteLine (testo)
Next contacolonne
a.WriteLine ("</TR>")
Next contarighe
'
a.WriteLine ("</Table><BR><HR></FONT></CENTER></BODY><HTML>")
a.Close
'
End Sub
'
' codice css style
Function memocodicecssstyle()
Dim codicecss
codicecss = codicecss & "<style>" & vbCrLf
codicecss = codicecss & "#tabelladati" & vbCrLf
codicecss = codicecss & "{" & vbCrLf
codicecss = codicecss & "font-family:""Trebuchet MS"", Arial, Helvetica, sans-serif;" & vbCrLf
codicecss = codicecss & "width:100%;" & vbCrLf
codicecss = codicecss & "border-collapse:collapse;" & vbCrLf
codicecss = codicecss & "}" & vbCrLf
codicecss = codicecss & "#tabelladati td, #tabelladati th" & vbCrLf
codicecss = codicecss & "{" & vbCrLf
codicecss = codicecss & "font-size:1em;" & vbCrLf
codicecss = codicecss & "border:1px solid #98bf21;" & vbCrLf
codicecss = codicecss & "padding:3px 7px 2px 7px;" & vbCrLf
codicecss = codicecss & "}" & vbCrLf
codicecss = codicecss & "#tabelladati th" & vbCrLf
codicecss = codicecss & "{" & vbCrLf
codicecss = codicecss & "font-size:1.1em;" & vbCrLf
codicecss = codicecss & "text-align:left;" & vbCrLf
codicecss = codicecss & "padding-top:5px;" & vbCrLf
codicecss = codicecss & "padding-bottom:4px;" & vbCrLf
codicecss = codicecss & "background-color:#A7C942;" & vbCrLf
codicecss = codicecss & "color:#ffffff;" & vbCrLf
codicecss = codicecss & "}" & vbCrLf
codicecss = codicecss & "#tabelladati tr.alt td" & vbCrLf
codicecss = codicecss & "{" & vbCrLf
codicecss = codicecss & "color:#000000;" & vbCrLf
codicecss = codicecss & "background-color:#EAF2D3;" & vbCrLf
codicecss = codicecss & "}" & vbCrLf
codicecss = codicecss & "</style>" & vbCrLf
'
memocodicecssstyle = codicecss
'
End Function
venerdì 19 aprile 2013
crea rubrica html
Attribute VB_Name = "crea_rubrica_html"
'
Option Explicit
'
' vba - excel
' converte il foglio attivo in una pagina html
'
Sub CreaRubricaHtml()
'
Dim txtcella, contarighe, quanterighe, riga, testo, fs, a, testotd
Dim quantecolonne, contacolonne, cartellap, nomefoglio, cartella, messaggio, foglio
nomefoglio = ActiveSheet.Name
Set foglio = Sheets(nomefoglio)
cartellap = "C:\"
cartella = cartellap & nomefoglio & ".html"
messaggio = "il nome della rubrica e': " & nomefoglio & vbCrLf
messaggio = messaggio & "(il mome del foglio attivo)" & vbCrLf
messaggio = messaggio & "cartella in cui sara' salvata la rubrica: " & vbCrLf
messaggio = messaggio & cartellap
MsgBox messaggio
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
Set a = fs.CreateTextFile(cartella, True)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column
'
testotd = "<TD ALIGN=" & Chr(34) & "left" & Chr(34) & " >"
' intestazione
a.WriteLine ("<HTML><HEAD><TITLE>")
a.WriteLine (nomefoglio)
a.WriteLine ("</TITLE></HEAD>")
testo = "<BODY bgcolor = " & Chr(34) & "#ccffff" & Chr(34) & ">"
a.WriteLine (testo)
a.WriteLine ("<CENTER><BR><HR><BR> ")
a.WriteLine (nomefoglio)
a.WriteLine ("<HR> <Table border>")
testo = "<FONT FACE=" & Chr(34) & "Arial" & Chr(34) & "SIZE=+1>"
a.WriteLine (testo)
' scrive tutte le righe e colonne
For contarighe = 1 To quanterighe
testo = "<TR VALIGN=" & Chr(34) & "bottom" & Chr(34) & ">"
a.WriteLine (testo)
For contacolonne = 1 To quantecolonne
txtcella = foglio.Cells(contarighe, contacolonne).Value
testo = testotd & txtcella & "</TD>"
a.WriteLine (testo)
Next contacolonne
a.WriteLine ("</TR>")
Next contarighe
a.WriteLine ("</Table><BR><HR></FONT></CENTER></BODY><HTML>")
a.Close
'
End Sub
'
Option Explicit
'
' vba - excel
' converte il foglio attivo in una pagina html
'
Sub CreaRubricaHtml()
'
Dim txtcella, contarighe, quanterighe, riga, testo, fs, a, testotd
Dim quantecolonne, contacolonne, cartellap, nomefoglio, cartella, messaggio, foglio
nomefoglio = ActiveSheet.Name
Set foglio = Sheets(nomefoglio)
cartellap = "C:\"
cartella = cartellap & nomefoglio & ".html"
messaggio = "il nome della rubrica e': " & nomefoglio & vbCrLf
messaggio = messaggio & "(il mome del foglio attivo)" & vbCrLf
messaggio = messaggio & "cartella in cui sara' salvata la rubrica: " & vbCrLf
messaggio = messaggio & cartellap
MsgBox messaggio
'
Set fs = CreateObject("Scripting.FileSystemObject")
'
Set a = fs.CreateTextFile(cartella, True)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column
'
testotd = "<TD ALIGN=" & Chr(34) & "left" & Chr(34) & " >"
' intestazione
a.WriteLine ("<HTML><HEAD><TITLE>")
a.WriteLine (nomefoglio)
a.WriteLine ("</TITLE></HEAD>")
testo = "<BODY bgcolor = " & Chr(34) & "#ccffff" & Chr(34) & ">"
a.WriteLine (testo)
a.WriteLine ("<CENTER><BR><HR><BR> ")
a.WriteLine (nomefoglio)
a.WriteLine ("<HR> <Table border>")
testo = "<FONT FACE=" & Chr(34) & "Arial" & Chr(34) & "SIZE=+1>"
a.WriteLine (testo)
' scrive tutte le righe e colonne
For contarighe = 1 To quanterighe
testo = "<TR VALIGN=" & Chr(34) & "bottom" & Chr(34) & ">"
a.WriteLine (testo)
For contacolonne = 1 To quantecolonne
txtcella = foglio.Cells(contarighe, contacolonne).Value
testo = testotd & txtcella & "</TD>"
a.WriteLine (testo)
Next contacolonne
a.WriteLine ("</TR>")
Next contarighe
a.WriteLine ("</Table><BR><HR></FONT></CENTER></BODY><HTML>")
a.Close
'
End Sub
m estrai primo spazio dx
Attribute VB_Name = "m_estrai_primo_spazio_dx"
'
Option Explicit
'
'vba - excel
' Estrae Stringa Dopo il primo spazio a destra
'
'
Sub EstraeStringaDopoilPrimoSpazioDestra()
Dim quanterighe, contarighe, foglio, contenuto1, contenuto2, colonnadascansionare, scrivicolonna, presente
Set foglio = Sheets(ActiveSheet.Name)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
colonnadascansionare = ActiveCell.Column ' prende la colonna della cella attiva
scrivicolonna = colonnadascansionare + 1 ' colonna dove scrivere il valore trovato
'
contarighe = 1
While contarighe <= quanterighe
contenuto1 = Trim(foglio.Cells(contarighe, colonnadascansionare).Value)
contenuto2 = Trim(foglio.Cells(contarighe, scrivicolonna).Value)
presente = InStr(contenuto1, " ")
If presente > 0 Then
If Len(contenuto2) > 0 Then
ActiveSheet.Cells(contarighe, colonnadascansionare).Value = "'" & Trim(Left(contenuto1, presente))
ActiveSheet.Cells(contarighe, scrivicolonna).Value = "'" & contenuto2 & Trim(Mid(contenuto1, (presente + 1), (Len(contenuto1) - presente)))
Else
ActiveSheet.Cells(contarighe, colonnadascansionare).Value = "'" & Trim(Left(contenuto1, presente))
ActiveSheet.Cells(contarighe, scrivicolonna).Value = "'" & Trim(Mid(contenuto1, (presente + 1), (Len(contenuto1) - presente)))
End If
End If
contarighe = contarighe + 1
Wend
'
End Sub
'
'
'
Option Explicit
'
'vba - excel
' Estrae Stringa Dopo il primo spazio a destra
'
'
Sub EstraeStringaDopoilPrimoSpazioDestra()
Dim quanterighe, contarighe, foglio, contenuto1, contenuto2, colonnadascansionare, scrivicolonna, presente
Set foglio = Sheets(ActiveSheet.Name)
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
colonnadascansionare = ActiveCell.Column ' prende la colonna della cella attiva
scrivicolonna = colonnadascansionare + 1 ' colonna dove scrivere il valore trovato
'
contarighe = 1
While contarighe <= quanterighe
contenuto1 = Trim(foglio.Cells(contarighe, colonnadascansionare).Value)
contenuto2 = Trim(foglio.Cells(contarighe, scrivicolonna).Value)
presente = InStr(contenuto1, " ")
If presente > 0 Then
If Len(contenuto2) > 0 Then
ActiveSheet.Cells(contarighe, colonnadascansionare).Value = "'" & Trim(Left(contenuto1, presente))
ActiveSheet.Cells(contarighe, scrivicolonna).Value = "'" & contenuto2 & Trim(Mid(contenuto1, (presente + 1), (Len(contenuto1) - presente)))
Else
ActiveSheet.Cells(contarighe, colonnadascansionare).Value = "'" & Trim(Left(contenuto1, presente))
ActiveSheet.Cells(contarighe, scrivicolonna).Value = "'" & Trim(Mid(contenuto1, (presente + 1), (Len(contenuto1) - presente)))
End If
End If
contarighe = contarighe + 1
Wend
'
End Sub
'
'
m cancella su valore riga
Attribute VB_Name = "m_cancella_su_valore_riga"
'
Option Explicit
'
' vba - excel
' cancella righe che contegono il valore della cella attiva
'
Sub CancellaRigheConValoreCorrente()
'
Dim ColonnaAttiva, corrente As String, quanterighe, contarighe
Dim valore As String, foglio
Set foglio = Sheets(ActiveSheet.Name)
ColonnaAttiva = ActiveCell.Column
valore = Trim(CStr(ActiveCell.Value))
'
Application.Cursor = xlWait
Application.ScreenUpdating = False
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
'
For contarighe = quanterighe To 1 Step -1 ' conteggio righe usate
corrente = Trim(CStr(foglio.Cells(contarighe, ColonnaAttiva).Value))
If corrente = valore Then
foglio.Rows(contarighe).Delete
End If
Next contarighe
'
Application.ScreenUpdating = True
Application.Cursor = xlDefault
'
End Sub
'
Option Explicit
'
' vba - excel
' cancella righe che contegono il valore della cella attiva
'
Sub CancellaRigheConValoreCorrente()
'
Dim ColonnaAttiva, corrente As String, quanterighe, contarighe
Dim valore As String, foglio
Set foglio = Sheets(ActiveSheet.Name)
ColonnaAttiva = ActiveCell.Column
valore = Trim(CStr(ActiveCell.Value))
'
Application.Cursor = xlWait
Application.ScreenUpdating = False
'
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
'
For contarighe = quanterighe To 1 Step -1 ' conteggio righe usate
corrente = Trim(CStr(foglio.Cells(contarighe, ColonnaAttiva).Value))
If corrente = valore Then
foglio.Rows(contarighe).Delete
End If
Next contarighe
'
Application.ScreenUpdating = True
Application.Cursor = xlDefault
'
End Sub
martedì 9 aprile 2013
m scrivi ps pdf campi
Attribute VB_Name = "m_scrivi_ps_pdf_campi"
'
Option Explicit
'
' crea griglia editabile per file pdf
' genera un file in formato PS-postscript
' tramite Ghostscript si crea il file in formato PDF
'
Sub ScriviFilePsPdfCampiEditabili()
Dim orizzontale, verticale, altezzacampo, lunghezzacampo
Dim contaaltezza, contacampi
Dim marginesinistro, partida, s As String
Dim lunghezzacampi, nomecampi, destinatarioemail
destinatarioemail = InputBox("destinatario email", "scelta", "")
Dim x, spostati
altezzacampo = 20
'lunghezzacampo = 30
orizzontale = 595 ' formato pagina a4
verticale = 842 ' formato pagina a4
marginesinistro = 21
partida = verticale - altezzacampo - altezzacampo - altezzacampo
contacampi = 0
'
nomecampi = Array("", "qta", "articolo", "descrizione", "nota", "note")
'
lunghezzacampi = Array(0, 35, 150, 250, 45, 70)
'
s = ""
s = s & "%!PS-Adobe-3.0 EPSF-3.0" & vbCrLf
s = s & "%%BoundingBox: 0 0 72 72" & vbCrLf
s = s & "%%EndComments" & vbCrLf
s = s & "%%BeginProlog /pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse " & "[ {ThisPage} << /Trans << /S /Dissolve >> >> /PUT pdfmark" & vbCrLf
s = s & "%%EndProlog" & vbCrLf
s = s & " " & vbCrLf
s = s & "%%BeginSetup" & vbCrLf
s = s & "%%EndSetup" & vbCrLf
s = s & " " & vbCrLf
s = s & "%%BeginPage:" & vbCrLf
s = s & " " & vbCrLf
'
spostati = marginesinistro
' intestazione della griglia
For x = 1 To UBound(lunghezzacampi)
lunghezzacampo = lunghezzacampi(x)
s = s & "/Times-Roman findfont 10 scalefont setfont" & vbCrLf
s = s & spostati & " 810 moveto" & vbCrLf
s = s & "(" & nomecampi(x) & ") show" & vbCrLf
spostati = spostati + lunghezzacampo + 2
Next x
' crea griglia
' campi editabili
For x = 1 To UBound(lunghezzacampi)
lunghezzacampo = lunghezzacampi(x)
For contaaltezza = partida To 61 Step -21
s = s & " " & vbCrLf
s = s & "[ /T (field" & nomecampi(x) & contacampi & x & ") % title" & vbCrLf
s = s & "/Subtype /Widget" & vbCrLf
s = s & "/FT /Tx % field type text box" & vbCrLf
s = s & "/V () % default value" & vbCrLf
's = s & "/Rect [ 25 619 116 639]" & vbCrLf
s = s & "/Rect [ " & marginesinistro & " " & contaaltezza & " " & (marginesinistro + lunghezzacampo) & " " & (contaaltezza + altezzacampo) & " ]" & vbCrLf
s = s & "/F 4 % field is printable" & vbCrLf
s = s & "/BS << /S /S /W 1 >> % border style solid, width = 1" & vbCrLf
s = s & "/MK <<" & vbCrLf
s = s & "/BC [ 1 0 0 ] % border color red" & vbCrLf
s = s & "/BG [ 1 1 1 ] >> % background color white" & vbCrLf
s = s & "/ANN pdfmark" & vbCrLf
s = s & " " & vbCrLf
contacampi = contacampi + 1
Next contaaltezza
'
marginesinistro = marginesinistro + lunghezzacampo + 1
'
Next x
'
' pulsante invio modulo tramite email
'
s = s & "[ /Rect [ 50 50 220 60 ]" & vbCrLf
s = s & "/Action << /Subtype /SubmitForm" & vbCrLf
s = s & "/F (mailto:" & destinatarioemail & ") >>" & vbCrLf
s = s & "/Flags 0" & vbCrLf
s = s & "/Subtype /Link" & vbCrLf
s = s & "/Border [ 1 1 1 ]" & vbCrLf
s = s & "/ANN pdfmark" & vbCrLf
'
s = s & "/Times-Roman findfont 10 scalefont setfont" & vbCrLf
s = s & "52 52 moveto" & vbCrLf
s = s & "(invia tramite e-mail) show" & vbCrLf
s = s & "showpage" & vbCrLf
'
s = s & "%%EndPage:" & vbCrLf
s = s & "%%EOF" & vbCrLf
'
' scrive il file ps
Dim fs, a
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\file-per-creazione-pdf.ps", True)
a.WriteLine (s)
a.Close
'
End Sub
'
Option Explicit
'
' crea griglia editabile per file pdf
' genera un file in formato PS-postscript
' tramite Ghostscript si crea il file in formato PDF
'
Sub ScriviFilePsPdfCampiEditabili()
Dim orizzontale, verticale, altezzacampo, lunghezzacampo
Dim contaaltezza, contacampi
Dim marginesinistro, partida, s As String
Dim lunghezzacampi, nomecampi, destinatarioemail
destinatarioemail = InputBox("destinatario email", "scelta", "")
Dim x, spostati
altezzacampo = 20
'lunghezzacampo = 30
orizzontale = 595 ' formato pagina a4
verticale = 842 ' formato pagina a4
marginesinistro = 21
partida = verticale - altezzacampo - altezzacampo - altezzacampo
contacampi = 0
'
nomecampi = Array("", "qta", "articolo", "descrizione", "nota", "note")
'
lunghezzacampi = Array(0, 35, 150, 250, 45, 70)
'
s = ""
s = s & "%!PS-Adobe-3.0 EPSF-3.0" & vbCrLf
s = s & "%%BoundingBox: 0 0 72 72" & vbCrLf
s = s & "%%EndComments" & vbCrLf
s = s & "%%BeginProlog /pdfmark where {pop} {userdict /pdfmark /cleartomark load put} ifelse " & "[ {ThisPage} << /Trans << /S /Dissolve >> >> /PUT pdfmark" & vbCrLf
s = s & "%%EndProlog" & vbCrLf
s = s & " " & vbCrLf
s = s & "%%BeginSetup" & vbCrLf
s = s & "%%EndSetup" & vbCrLf
s = s & " " & vbCrLf
s = s & "%%BeginPage:" & vbCrLf
s = s & " " & vbCrLf
'
spostati = marginesinistro
' intestazione della griglia
For x = 1 To UBound(lunghezzacampi)
lunghezzacampo = lunghezzacampi(x)
s = s & "/Times-Roman findfont 10 scalefont setfont" & vbCrLf
s = s & spostati & " 810 moveto" & vbCrLf
s = s & "(" & nomecampi(x) & ") show" & vbCrLf
spostati = spostati + lunghezzacampo + 2
Next x
' crea griglia
' campi editabili
For x = 1 To UBound(lunghezzacampi)
lunghezzacampo = lunghezzacampi(x)
For contaaltezza = partida To 61 Step -21
s = s & " " & vbCrLf
s = s & "[ /T (field" & nomecampi(x) & contacampi & x & ") % title" & vbCrLf
s = s & "/Subtype /Widget" & vbCrLf
s = s & "/FT /Tx % field type text box" & vbCrLf
s = s & "/V () % default value" & vbCrLf
's = s & "/Rect [ 25 619 116 639]" & vbCrLf
s = s & "/Rect [ " & marginesinistro & " " & contaaltezza & " " & (marginesinistro + lunghezzacampo) & " " & (contaaltezza + altezzacampo) & " ]" & vbCrLf
s = s & "/F 4 % field is printable" & vbCrLf
s = s & "/BS << /S /S /W 1 >> % border style solid, width = 1" & vbCrLf
s = s & "/MK <<" & vbCrLf
s = s & "/BC [ 1 0 0 ] % border color red" & vbCrLf
s = s & "/BG [ 1 1 1 ] >> % background color white" & vbCrLf
s = s & "/ANN pdfmark" & vbCrLf
s = s & " " & vbCrLf
contacampi = contacampi + 1
Next contaaltezza
'
marginesinistro = marginesinistro + lunghezzacampo + 1
'
Next x
'
' pulsante invio modulo tramite email
'
s = s & "[ /Rect [ 50 50 220 60 ]" & vbCrLf
s = s & "/Action << /Subtype /SubmitForm" & vbCrLf
s = s & "/F (mailto:" & destinatarioemail & ") >>" & vbCrLf
s = s & "/Flags 0" & vbCrLf
s = s & "/Subtype /Link" & vbCrLf
s = s & "/Border [ 1 1 1 ]" & vbCrLf
s = s & "/ANN pdfmark" & vbCrLf
'
s = s & "/Times-Roman findfont 10 scalefont setfont" & vbCrLf
s = s & "52 52 moveto" & vbCrLf
s = s & "(invia tramite e-mail) show" & vbCrLf
s = s & "showpage" & vbCrLf
'
s = s & "%%EndPage:" & vbCrLf
s = s & "%%EOF" & vbCrLf
'
' scrive il file ps
Dim fs, a
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile("c:\file-per-creazione-pdf.ps", True)
a.WriteLine (s)
a.Close
'
End Sub
lunedì 8 aprile 2013
m scrivi fdf
Attribute VB_Name = "m_scrivi_fdf"
'
Option Explicit
'
' un unico file PDF per visualizzare i dati del foglio Excel
' i nomi dei campi del file Pdf debbono essere gli stessi
' presenti una prima riga del foglio excel.
' per ogni riga del foglio excel viene generato un file fdf.
'
' esempio file fdf:
'%FDF-1.2
'1 0 obj
'<<
' /FDF
' <<
' /Fields [
' << /V (1) /T (an_conto)>>
' << /V (nominativo) /T (an_descr1)>>
' << /V (indirizzo) /T (an_indir)>>
' << /V (cap) /T (an_cap)>>
' << /V (città) /T (an_citta)>>
' << /V (prov) /T (an_prov)>>
' ]
' /F (C:\\schedefdf\\scheda-dati.pdf)
' /ID [ ()()]
' >>
'>>
'endobj
'trailer
'<<
'/Root 1 0 R
'>>
'%%EOF
'
'
Sub ScriviFileFdf()
Dim quanterighe, contarighe, foglio, quantecolonne, contacolonne, risposta
Dim cartellascrittura
Dim intestazioni(), contenuti(), filepdf, filefdf
Set foglio = Sheets(ActiveSheet.Name)
'
' il nome del file pdf su cui visualizzare i dati del foglio
' i momi dei campi debbono essere gli stessi di quelli presenti sulla
cartellascrittura = "C:\schedefdf\"
risposta = VerificaEsistenzaCartella(cartellascrittura)
'
'cartellascrittura = InputBox("cartella dove scrivere file fdf:", "scelta", "c:\temp\")
' prima riga del foglio
filepdf = "C:\\lschedefdf\\scheda-dati.pdf"
'
' conteggio righe e colonne
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column
'
ReDim intestazioni(quantecolonne)
ReDim contenuti(quantecolonne)
'
contacolonne = 1
' utilizza i nomi inseriti nella prima riga come nome dei campi
'
While contacolonne <= quantecolonne
intestazioni(contacolonne) = foglio.Cells(1, contacolonne).Value
contacolonne = contacolonne + 1
Wend
'
contarighe = 1
'
While contarighe <= quanterighe
contacolonne = 1
While contacolonne <= quantecolonne
contenuti(contacolonne) = foglio.Cells(contarighe, contacolonne).Value
contacolonne = contacolonne + 1
Wend
' il file fdf prende il nome dal numero riga
filefdf = cartellascrittura & contarighe & ".fdf"
' in alternativa ii contenuto di una cella diventa il nome del file fdf.
' filefdf = cartellascrittura & trim(foglio.Cells(contarighe, "A").Value) & ".fdf"
Call funscrivifdf(intestazioni, contenuti, filepdf, filefdf)
contarighe = contarighe + 1
Wend
'
End Sub
'
Sub funscrivifdf(campi, valori, filepdf, filefdf)
Dim quanti, conta, nomecampo, valore
Dim s
quanti = UBound(campi)
s = ""
s = s & "%FDF-1.2" & vbCrLf
s = s & "1 0 obj" & vbCrLf
s = s & "<<" & vbCrLf
s = s & " /FDF" & vbCrLf
s = s & " <<" & vbCrLf
'
s = s & " /Fields [ " & vbCrLf
For conta = 1 To quanti
nomecampo = campi(conta)
valore = valori(conta)
s = s & " << /V (" & valore & ") /T (" & nomecampo & ")>>" & vbCrLf
Next conta
'
s = s & " ]" & vbCrLf
'
s = s & " /F (" & filepdf & ")" & vbCrLf
s = s & " /ID [ ()()]" & vbCrLf
s = s & " >>" & vbCrLf
s = s & ">>" & vbCrLf
s = s & "endobj" & vbCrLf
s = s & "trailer" & vbCrLf
s = s & "<<" & vbCrLf
s = s & "/Root 1 0 R" & vbCrLf
s = s & ">>" & vbCrLf
s = s & "%%EOF" & vbCrLf
'
Dim fs, a, archivio
archivio = filefdf
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(archivio, True)
a.WriteLine (s)
a.Close
'
End Sub
'
Function VerificaEsistenzaCartella(cartella)
Dim fso, msg, crea
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(cartella)) Then
' esiste
Else
' non esiste e cre la cartella
Set crea = fso.CreateFolder(cartella)
End If
'
End Function
'
'
Option Explicit
'
' un unico file PDF per visualizzare i dati del foglio Excel
' i nomi dei campi del file Pdf debbono essere gli stessi
' presenti una prima riga del foglio excel.
' per ogni riga del foglio excel viene generato un file fdf.
'
' esempio file fdf:
'%FDF-1.2
'1 0 obj
'<<
' /FDF
' <<
' /Fields [
' << /V (1) /T (an_conto)>>
' << /V (nominativo) /T (an_descr1)>>
' << /V (indirizzo) /T (an_indir)>>
' << /V (cap) /T (an_cap)>>
' << /V (città) /T (an_citta)>>
' << /V (prov) /T (an_prov)>>
' ]
' /F (C:\\schedefdf\\scheda-dati.pdf)
' /ID [ ()()]
' >>
'>>
'endobj
'trailer
'<<
'/Root 1 0 R
'>>
'%%EOF
'
'
Sub ScriviFileFdf()
Dim quanterighe, contarighe, foglio, quantecolonne, contacolonne, risposta
Dim cartellascrittura
Dim intestazioni(), contenuti(), filepdf, filefdf
Set foglio = Sheets(ActiveSheet.Name)
'
' il nome del file pdf su cui visualizzare i dati del foglio
' i momi dei campi debbono essere gli stessi di quelli presenti sulla
cartellascrittura = "C:\schedefdf\"
risposta = VerificaEsistenzaCartella(cartellascrittura)
'
'cartellascrittura = InputBox("cartella dove scrivere file fdf:", "scelta", "c:\temp\")
' prima riga del foglio
filepdf = "C:\\lschedefdf\\scheda-dati.pdf"
'
' conteggio righe e colonne
quanterighe = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row
quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column
'
ReDim intestazioni(quantecolonne)
ReDim contenuti(quantecolonne)
'
contacolonne = 1
' utilizza i nomi inseriti nella prima riga come nome dei campi
'
While contacolonne <= quantecolonne
intestazioni(contacolonne) = foglio.Cells(1, contacolonne).Value
contacolonne = contacolonne + 1
Wend
'
contarighe = 1
'
While contarighe <= quanterighe
contacolonne = 1
While contacolonne <= quantecolonne
contenuti(contacolonne) = foglio.Cells(contarighe, contacolonne).Value
contacolonne = contacolonne + 1
Wend
' il file fdf prende il nome dal numero riga
filefdf = cartellascrittura & contarighe & ".fdf"
' in alternativa ii contenuto di una cella diventa il nome del file fdf.
' filefdf = cartellascrittura & trim(foglio.Cells(contarighe, "A").Value) & ".fdf"
Call funscrivifdf(intestazioni, contenuti, filepdf, filefdf)
contarighe = contarighe + 1
Wend
'
End Sub
'
Sub funscrivifdf(campi, valori, filepdf, filefdf)
Dim quanti, conta, nomecampo, valore
Dim s
quanti = UBound(campi)
s = ""
s = s & "%FDF-1.2" & vbCrLf
s = s & "1 0 obj" & vbCrLf
s = s & "<<" & vbCrLf
s = s & " /FDF" & vbCrLf
s = s & " <<" & vbCrLf
'
s = s & " /Fields [ " & vbCrLf
For conta = 1 To quanti
nomecampo = campi(conta)
valore = valori(conta)
s = s & " << /V (" & valore & ") /T (" & nomecampo & ")>>" & vbCrLf
Next conta
'
s = s & " ]" & vbCrLf
'
s = s & " /F (" & filepdf & ")" & vbCrLf
s = s & " /ID [ ()()]" & vbCrLf
s = s & " >>" & vbCrLf
s = s & ">>" & vbCrLf
s = s & "endobj" & vbCrLf
s = s & "trailer" & vbCrLf
s = s & "<<" & vbCrLf
s = s & "/Root 1 0 R" & vbCrLf
s = s & ">>" & vbCrLf
s = s & "%%EOF" & vbCrLf
'
Dim fs, a, archivio
archivio = filefdf
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(archivio, True)
a.WriteLine (s)
a.Close
'
End Sub
'
Function VerificaEsistenzaCartella(cartella)
Dim fso, msg, crea
Set fso = CreateObject("Scripting.FileSystemObject")
If (fso.FolderExists(cartella)) Then
' esiste
Else
' non esiste e cre la cartella
Set crea = fso.CreateFolder(cartella)
End If
'
End Function
'
unisci fogli tramite sql
Attribute VB_Name = "unisci_fogli_tramite_sql"
'
Option Explicit
'
' tramite istruzione sql
' raggruppa in nuovo foglio i dati di due fogli
' contenenti la medesima intestazione di colonna.
' esempio:
' Foglio1, cella a1 = articolo
' Foglio2, cella a1 = articolo
'
Sub componiStringaSql()
'
Dim stringasql As String, fogliodestinazione
Dim foglio1, foglio2
foglio1 = "Foglio1"
foglio2 = "Foglio2"
'
stringasql = ""
stringasql = stringasql & " Select * from [" & foglio1 & "$]"
stringasql = stringasql & " UNION "
stringasql = stringasql & " Select * from [" & foglio2 & "$]"
'
Sheets.Add
fogliodestinazione = ActiveSheet.Name
Call EseguiSqlExcel(stringasql, fogliodestinazione)
'
End Sub
'
Sub EseguiSqlExcel(stringasql As String, fogliodestinazione)
'On Error Resume Next
Dim oggConnection, oggRecordset, rifcartella, i
rifcartella = ThisWorkbook.FullName
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Set oggConnection = CreateObject("ADODB.Connection")
Set oggRecordset = CreateObject("ADODB.Recordset")
oggConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & rifcartella & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"
'
oggRecordset.Open stringasql, oggConnection, adOpenStatic, adLockOptimistic, adCmdText
'
' intestazione - nome campi
'
For i = 0 To oggRecordset.Fields.Count - 1
Sheets(fogliodestinazione).Cells(1, (i + 1)) = oggRecordset.Fields(i).Name
Next
'
' scrive il recordset
Sheets(fogliodestinazione).Range("A2").CopyFromRecordset oggRecordset
'
End Sub
'
'
Option Explicit
'
' tramite istruzione sql
' raggruppa in nuovo foglio i dati di due fogli
' contenenti la medesima intestazione di colonna.
' esempio:
' Foglio1, cella a1 = articolo
' Foglio2, cella a1 = articolo
'
Sub componiStringaSql()
'
Dim stringasql As String, fogliodestinazione
Dim foglio1, foglio2
foglio1 = "Foglio1"
foglio2 = "Foglio2"
'
stringasql = ""
stringasql = stringasql & " Select * from [" & foglio1 & "$]"
stringasql = stringasql & " UNION "
stringasql = stringasql & " Select * from [" & foglio2 & "$]"
'
Sheets.Add
fogliodestinazione = ActiveSheet.Name
Call EseguiSqlExcel(stringasql, fogliodestinazione)
'
End Sub
'
Sub EseguiSqlExcel(stringasql As String, fogliodestinazione)
'On Error Resume Next
Dim oggConnection, oggRecordset, rifcartella, i
rifcartella = ThisWorkbook.FullName
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = &H1
Set oggConnection = CreateObject("ADODB.Connection")
Set oggRecordset = CreateObject("ADODB.Recordset")
oggConnection.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & rifcartella & ";" & _
"Extended Properties=""Excel 8.0;HDR=Yes;"";"
'
oggRecordset.Open stringasql, oggConnection, adOpenStatic, adLockOptimistic, adCmdText
'
' intestazione - nome campi
'
For i = 0 To oggRecordset.Fields.Count - 1
Sheets(fogliodestinazione).Cells(1, (i + 1)) = oggRecordset.Fields(i).Name
Next
'
' scrive il recordset
Sheets(fogliodestinazione).Range("A2").CopyFromRecordset oggRecordset
'
End Sub
'
venerdì 5 aprile 2013
riconciliazione cg banca
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
'
'
'
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
'
'
Iscriviti a:
Post (Atom)