vbs estrae dal file righe con codici intrastat

‘

‘

option explicit

'

' vbs legge un file di testo

' ed estrare solo le righe contenti un numero lungo otto cifre.

' esempio: ricerca codici Intrastat.

'

dim spazi

spazi = "                                                              "

'

dim nomearchivio

nomearchivio = "C:\filepdfatesto.txt"

'

dim dblog,  slog

dblog = "C:\filepdfatesto-filtrato-a.txt"

call SovraScriviFile(dblog, "")

'

'

call leggielenco(nomearchivio)

'

call ScriviFileJollyAppend(dblog, "F")

'

' ====

sub leggielenco(filedaleggere)

 

dim objFSO, objFile, strLine, trovato,  trovato2, chiave

dim primaparte, secondaparte, srisultato

 

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.OpenTextFile(filedaleggere, 1)

'

Do While objFile.AtEndOfStream = False

   strLine = objFile.ReadLine

   if len(trim(strLine)) > 0 then

      trovato =  TrovaValore(strLine,"\s\d{8}\s")

      if len(trovato) > 0 then

         slog = strLine

         call ScriviFileJollyAppend(dblog, slog)

      end if

   end if

'

'

Loop

'

'

end sub

'

' ====================================

'

Sub ScriviFileJollyAppend(pNomeArchivio, pcosascrivere)

dim fso,  rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

If (fso.FileExists(pNomeArchivio)) Then

      'msg = filespec & " esiste."

       Set rifefile = fso.OpenTextFile(pNomeArchivio, 8)

Else

      'msg = filespec & " Non esiste."

       Set rifefile = fso.CreateTextFile(pNomeArchivio, TRUE)

End If

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' === sovra scrive file ===================

'

Sub SovraScriviFile(pNomeArchivio, pcosascrivere)

dim fso,  rifefile

Set fso=CreateObject("Scripting.FileSystemObject")

Set rifefile = fso.CreateTextFile(pNomeArchivio, TRUE)

rifefile.WriteLine(pcosascrivere)

rifefile.Close

set rifefile = Nothing

End Sub

'

' =================

'

Function TrovaValore(strVal, comecercare) 'As String

TrovaValore = ""

Dim sParts, sPart, rPart 'As Object

Set rPart = CreateObject("VBScript.RegExp")

rPart.Global = True

rPart.IgnoreCase = True

rPart.pattern = comecercare '

' test di ricerca

if rPart.Test(strVal) then

   Set sParts = rPart.Execute(strVal)

   ' restituisce il primo risultato

   For Each sPart In sParts

      TrovaValore = sParts(0)

      Exit For

   Next 'sPart

   else

   TrovaValore = ""

   end if

Set sParts = Nothing

End Function

'

' =================

'

vba excel esegue ipconfig e scrive sul foglio gli indirizzi ip

 

'

Option Explicit

'

Dim riga

'

' esegue ipconfig e scrive sul foglio excel gli indirizzi ip.

' gli antivirus tendono a bloccare una simile operazione.

'

Sub leggilineadicomando()

Dim objShell, objExecObject, strLine, strIP

Set objShell = CreateObject("WScript.Shell")

Set objExecObject = objShell.Exec("%comspec% /c ipconfig.exe")

 

Do Until objExecObject.StdOut.AtEndOfStream

 strLine = objExecObject.StdOut.ReadLine()

 strIP = InStr(strLine, "Address")

' If strIP <> 0 Then

    'Wscript.Echo strLine

    riga = riga + 1

    ActiveSheet.Cells(riga, 1).Value = strLine

' End If

Loop

'

End Sub

vba excel funzioni solo numeri e caratteri e solo telefoni

‘ Solo Numeri E caratteri

‘ esempio:

‘  

ddd,122/455     = ddd122455

 

 

Function SoloNumeriEcaratteri(S As String)

With CreateObject("vbscript.regexp")

  .Pattern = "[^0-9A-Za-z]"

  .IgnoreCase = True

  .Global = True

  SoloNumeriEcaratteri = .Replace(S, "")

End With

End Function

'

‘

‘

Function SoloTelefoni(S As String, tipo As String)

Dim telefono, uncarattere

With CreateObject("vbscript.regexp")

  .Pattern = "[^0-9]"

  .IgnoreCase = True

  .Global = True

  telefono = .Replace(S, "")

End With

'

SoloTelefoni = telefono

uncarattere = Left(telefono, 1)

If tipo = "fisso" Then

   If uncarattere = "0" Then

      SoloTelefoni = telefono

   Else

      SoloTelefoni = ""

   End If

End If

If tipo = "cellulare" Then

   If uncarattere = "3" Then

      SoloTelefoni = telefono

   Else

      SoloTelefoni = ""

   End If

End If

'

End Function

 

 

il tasto f4 del foglio Excel viene settato per la ricerca di una partita iva sul sistema Vies

'

Option Explicit

'

' il tasto f4, del foglio Excel, viene settato, per la ricerca

' di una partita iva, sul sistema Vies

'

Public mcodicehtml

'

Sub settaTastoF4()

Application.OnKey "{F4}", "tastof4CercaPartitaIvaVies"

End Sub

'

Sub tastof4CercaPartitaIvaVies()

Dim riga, piva, colonna

colonna = "A" ' colonna del foglio dove si trova la partita iva

riga = ActiveCell.Row

piva = ActiveSheet.Cells(riga, colonna).Value

Call CercaPartitaIvaVies(piva)

End Sub

'

Sub CercaPartitaIvaVies(passapiva)

    Dim i As Long

    Dim IE As Object

    Dim objElement As Object

    Dim objCollection As Object

    Dim HTMLDOC, htmlcodice, htmltesto, stxt

 

    ' Crea Oggetto Internet Explorer

    Set IE = CreateObject("InternetExplorer.Application")

 

    ' internet explorer non visibile, in attesa di risposta

    IE.Visible = False

 

    ' link al sito

    IE.Navigate "http://www1.agenziaentrate.gov.it/servizi/vies/vies.htm?p=&s=IT"

 

    ' Statusbar

    Application.StatusBar = "in attesa di connessione. Please wait..."

 

    ' attende che IE venga caricato...

    Do While IE.Busy

        Application.Wait DateAdd("s", 1, Now)

    Loop

'

' Rircerca dei campi per id :

'

Application.StatusBar = "Attesa invio dati. Attedere."

 

Set objCollection = IE.Document.getElementsByTagName("input")

 

    i = 0

    While i < objCollection.Length

        If objCollection(i).ID = "vies_piva" Then

        'If objCollection(i).Name = "piva" Then

            ' Set testo di ricerca

            objCollection(i).Value = passapiva

         Else

            If objCollection(i).Type = "submit" And _

               objCollection(i).ID = "vies_formfcs" Then

              ' objCollection(i).Name = "" Then

 '

               ' tag trovato

              Set objElement = objCollection(i)

 '

        End If

        End If

        i = i + 1

    Wend

   

    objElement.Click    ' click sul bottone di ricerca

   

    ' attende risposta da IE.

    Do While IE.Busy

        Application.Wait DateAdd("s", 1, Now)

    Loop

 

    ' IE visibile

    IE.Visible = True

 '

    Set HTMLDOC = IE.Document

    'MsgBox HTMLDOC.body.innerText

    htmlcodice = HTMLDOC.body.innerhtml

    htmltesto = HTMLDOC.body.innerText

    mcodicehtml = HTMLDOC.body.innerhtml

    '

    ' stxt = WriteLineToFile(htmlcodice & vbCrLf & htmltesto)

    ' stxt = WriteLineToFile(trovaesito(htmlcodice))

    ' Application.Wait DateAdd("s", 10, Now)

    ' IE.Quit

    '

    '

    Set IE = Nothing

    Set objElement = Nothing

    Set objCollection = Nothing

 '

    Application.StatusBar = ""

'

End Sub

'

' nel caso si voglia scrivere su file l'esito della ricerca

'

Function WriteLineToFile(ptesto)

'

Const ForReading = 1, ForWriting = 2

Dim fso, f

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.OpenTextFile("c:\dati-scritti-testfile.txt", ForWriting, True)

f.WriteLine ptesto ' "VBScript is fun!"

f.Close

'

End Function

'

 

 

 

Unisci Dati di Bilancio Di Due Esercizi

‘ Unisci Dati di Bilancio Di Due Esercizi

Sub UnisciDatidiBilancioDiDueEsercizi()

Dim nomeFoglioInput, nomeFoglioOutput, esercizio, azione As String

'

esercizio = 2018

nomeFoglioOutput = "dati"

' primo esercizio

nomeFoglioInput = "aperture"

azione = "pulisciDestinazione"

Call copiadatifoglio(nomeFoglioInput, nomeFoglioOutput, esercizio, azione)

' secondo esercizio

esercizio = esercizio - 1

nomeFoglioInput = "esercizi"

azione = "LasciaPerdere"

Call copiadatifoglio("esercizi", nomeFoglioOutput, esercizio, azione)

'

End Sub

'

Sub copiadatifoglio(nomeFoglioInput, nomeFoglioOutput, esercizio, azione As String)

Dim icontar, icontac, irighe, icolonne, lesercizio

Dim ColonnaAnnoEsercizio

ColonnaAnnoEsercizio = "E"

Dim ifoglio, ofoglio, sriga

Set ifoglio = Sheets(nomeFoglioInput)

Set ofoglio = Sheets(nomeFoglioOutput)

 

'

If azione = "pulisciDestinazione" Then

   ofoglio.Activate

   ofoglio.Range("A2", Cells(ofoglio.UsedRange.Rows.Count, ofoglio.UsedRange.Columns.Count)).ClearContents

End If

sriga = 1

'

irighe = ifoglio.UsedRange.Rows.Count

icolonne = ifoglio.UsedRange.Columns.Count

sriga = ofoglio.UsedRange.Rows.Count

 

'

For icontar = 2 To irighe

    lesercizio = ifoglio.Cells(icontar, ColonnaAnnoEsercizio).Value

    If lesercizio = esercizio Then

       sriga = sriga + 1

       For icontac = 1 To icolonne

           ofoglio.Cells(sriga, icontac) = ifoglio.Cells(icontar, icontac)

       Next icontac

    End If

Next icontar

'

End Sub

vba Elimina Righe Cella Non Vuota

Sub EliminaRigheCellaNonVuota()

Dim contar, foglio, leggicolonna, contenuto

Dim cosacancellare

'

Set foglio = Sheets(ActiveSheet.Name)

'

contar = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

leggicolonna = ActiveCell.Column

 

'

While contar > 1

      contenuto = Trim(foglio.Cells(contar, leggicolonna).Value)

      '

      If Len(contenuto) > 0 Then

         foglio.Rows(contar).Delete

      End If

'

    foglio.Cells(contar, leggicolonna).Activate

    contar = contar - 1

Wend

'

End Sub

 

vba - Elimina Righe Cella Vuota

Sub EliminaRigheCellaVuota()

Dim contar, foglio, leggicolonna, contenuto

Dim cosacancellare

'

Set foglio = Sheets(ActiveSheet.Name)

'

contar = Range(foglio.UsedRange.Cells(foglio.UsedRange.Rows.Count, 1).Address).Row

leggicolonna = ActiveCell.Column ‘  riferimento colonna sulla cella attiva

 

'

While contar > 1

      contenuto = Trim(foglio.Cells(contar, leggicolonna).Value)

      '

      If Len(contenuto) = 0 Then

         foglio.Rows(contar).Delete

      End If

'

    foglio.Cells(contar, leggicolonna).Activate

    contar = contar - 1

Wend

'

End Sub

'