martedì 27 marzo 2018

vba Excel Copia Righe con formula Non In Errore

Option Explicit

'

' vba Excel Copia Righe con formula Non In Errore

'

Sub CopiaRigheNonInErrore()

Dim quanterighe, contarighe, foglio, contacolonne, quantecolonne, contenuto

Dim sfoglio, sriga

Set foglio = Sheets(ActiveSheet.Name)

Dim colonnainerrore

colonnainerrore = ActiveCell.Column ' cella attiva

Sheets.Add

Set sfoglio = Sheets(ActiveSheet.Name)

foglio.Activate

'

'

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

quantecolonne = Range(foglio.UsedRange.Cells(1, foglio.UsedRange.Columns.Count).Address).Column

contacolonne = 1

contarighe = 1

sriga = 0

'

While contarighe <= quanterighe

   If IsError(foglio.Cells(contarighe, colonnainerrore).Value) = False Then

      contacolonne = 1

      sriga = sriga + 1

      foglio.Cells(contarighe, colonnainerrore).Select

      While contacolonne <= quantecolonne

         contenuto = foglio.Cells(contarighe, contacolonne).Value

         sfoglio.Cells(sriga, contacolonne).Value = foglio.Cells(contarighe, contacolonne).Value

         contacolonne = contacolonne + 1

      Wend

   End If

   contarighe = contarighe + 1

Wend

'

End Sub

'

giovedì 22 marzo 2018

vba Excel verifica una partita iva di un operatore non Vies

'

‘ vba Excel verifica una partita iva di un operatore non Vies

‘ scrive l’esito della ricerca sia in formato Html che testo.

Option Explicit

'

Public Const cartellaarchivio = "C:\archivio-dati\"

Public risposta

'

Sub settaTastoF4CercaPartitaIvaAEchiudi()

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

End Sub

'

Sub tastoCercaPartitaIvaAEchiudi()

Dim riga, piva, contarighe, maxrighe, sriga, contenuto

Dim colonnapartitaiva, colonnarisposta

colonnapartitaiva = "A"

colonnarisposta = "O"

riga = ActiveCell.Row

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

Call CercaPartitaIvaAEchiudi(piva)

'

ActiveSheet.Cells(riga, colonnarisposta).Value = risposta

'

'

End Sub

'

Sub CercaPartitaIvaAEchiudi(passapiva)

    Dim i As Long

    Dim IE As Object

    Dim objElement As Object

    Dim objCollection As Object

 '

    Dim HTMLDOC, htmltesto, codicehtml, presente, presente1, presente2

 

   ' Create InternetExplorer Object

    Set IE = CreateObject("InternetExplorer.Application")

 

   ' applicazione non visibile

   IE.Visible = False

 

    ' url

    IE.Navigate "https://telematici.agenziaentrate.gov.it/VerificaPIVA/IVerificaPiva.jsp"

 

    ' messaggio di attesa

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

 

    ' attende il caricamento della pagina.

    Do While IE.Busy

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

    Loop

 

    ' esempio di ricerca per input tags:

    '   1. Text field

    '   <input type="text" class="textfield" name="s" size="24" value="" />

    '

    '   2. Button

    '   <input type="submit" class="button" value="" />

    ' messaggio di attesa

    Application.StatusBar = "Caricamento in corso wait..."

 

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

 

    i = 0

    While i < objCollection.Length

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

 

            ' inserisce il valore

            objCollection(i).Value = passapiva

 

        Else

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

           '   objCollection(i).Name = "" Then

           '

           '   ' "Search" button trovato

           '    Set objElement = objCollection(i)

           '

           ' End If

        End If

        i = i + 1

    Wend

  '  objElement.Click    ' click sul button search

   

    ' attende il caricamento della pagina.

    Do While IE.Busy

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

    Loop

 

    ' oggetto IE visibile

    IE.Visible = True

'

    Set HTMLDOC = IE.Document

    htmltesto = HTMLDOC.body.innerText

    codicehtml = HTMLDOC.body.innerhtml

    presente = 0

    While presente = 0

       presente1 = InStr(htmltesto, "PARTITA IVA ATTIVA")

       presente2 = InStr(htmltesto, "PARTITA IVA CESSATA")

       If presente1 > 0 Then

          presente = presente1

          risposta = "trovato"

       End If

       If presente2 > 0 Then

          presente = presente2

          risposta = "cessato"

       End If

       If presente > 0 Then

          Call ScriviDatiToFile(cartellaarchivio & passapiva & ".txt", htmltesto)

          Call ScriviDatiToFile(cartellaarchivio & passapiva & ".html", codicehtml)

       End If

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

       Set HTMLDOC = IE.Document

       htmltesto = HTMLDOC.body.innerText

       codicehtml = HTMLDOC.body.innerhtml

       '

 

       '

    Wend

'

    IE.Quit

'

'

    Set IE = Nothing

    Set objElement = Nothing

    Set objCollection = Nothing

 

    Application.StatusBar = ""

'

'

End Sub

'

Sub ScriviDatiToFile(parchivio, ptesto)

'

Const ForReading = 1, ForWriting = 2

Dim fso, f

Set fso = CreateObject("Scripting.FileSystemObject")

Set f = fso.OpenTextFile(parchivio, ForWriting, True)

f.WriteLine ptesto '

f.Close

'

End Sub

 

 

domenica 4 marzo 2018

vba Excel Archivia Fattura

'

Option Explicit

'

' vba Excel Archivia Fattura

Sub ArchiviaFattura()

Dim sigla, articolo

Dim campi, ritorno, quanti, valori

campi = Array("errore", "colonna sigla(0 se manca)", "articolo", "descrizione", "misura", "quantita", "prezzo", "importo", "nr. fattura fornitore", "nr protocollo azienda", "data fattura")

valori = Array("", "A", "B", "C", "D", "E", "F", "G", ".", "", ".", ".", ".")

ritorno = creamaskeraDef(campi, valori)

quanti = UBound(ritorno)

'

Dim colsigla, colart, coldescr, colum, colqta, colpre, colimp

colsigla = ritorno(1)

colart = ritorno(2)

coldescr = ritorno(3)

colum = ritorno(4)

colqta = ritorno(5)

colpre = ritorno(6)

colimp = ritorno(7)

'

If colsigla = 0 Then

sigla = InputBox("dammi la sigla aziendale del fornitore", "scelta", "")

End If

'MsgBox valori(8) & vbCrLf & valori(9) & vbCrLf & valori(10)

Dim quanter, contar, foglio, contenuto, colonnai, sfoglio, sriga

Set foglio = Sheets("fattura")

Set sfoglio = Sheets("fatture")

'

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

sriga = Range(sfoglio.UsedRange.Cells(sfoglio.UsedRange.Rows.Count, 1).Address).Row

sriga = sriga + 1

'

contar = 2

While contar <= quanter

      sriga = sriga + 1

      If colsigla <> 0 Then

         sfoglio.Cells(sriga, "A").Value = foglio.Cells(contar, colsigla).Value  ' sigla

      Else

         sfoglio.Cells(sriga, "A").Value = sigla ' sigla

      End If

      If colart <> 0 Then ' articolo

         articolo = Trim(foglio.Cells(contar, colart).Value)

         If IsNumeric(articolo) = True Then

            sfoglio.Cells(sriga, "B").Value = "'" & articolo

         Else

            sfoglio.Cells(sriga, "B").Value = articolo

         End If

      End If

      If coldescr <> 0 Then sfoglio.Cells(sriga, "c").Value = foglio.Cells(contar, coldescr).Value ' descr

      If colum <> 0 Then sfoglio.Cells(sriga, "d").Value = foglio.Cells(contar, colum).Value ' um

      If colqta <> 0 Then sfoglio.Cells(sriga, "e").Value = foglio.Cells(contar, colqta).Value ' qta

      If colpre <> 0 Then sfoglio.Cells(sriga, "f").Value = foglio.Cells(contar, colpre).Value ' prezzo

      If colimp <> 0 Then sfoglio.Cells(sriga, "G").Value = foglio.Cells(contar, colimp).Value ' importo

      sfoglio.Cells(sriga, "H").Value = ActiveWorkbook.Name ' fornitore

      sfoglio.Cells(sriga, "I").Value = ritorno(8) ' nr_fattura

      sfoglio.Cells(sriga, "J").Value = ritorno(9) ' protocollo

      sfoglio.Cells(sriga, "K").Value = ritorno(10) ' data ft

      contar = contar + 1

Wend

'

'

End Sub

'

 

'

Function creamaskeraDef(campi, valori)

On Error GoTo esci

Dim H, IE, objtag, quanti, conta

quanti = UBound(campi)

ReDim ritorno(quanti)

ritorno(0) = "errore"

'

Set IE = CreateObject("InternetExplorer.Application")

IE.navigate "about:blank" '

IE.Visible = True

IE.Height = 700

IE.Width = 550

IE.MenuBar = False

IE.Toolbar = False

IE.StatusBar = False

IE.resizable = True

'

IE.document.Title = "azienda - "

'

H = ""

H = H + "<html><body><center>"

H = H + " inserimento<br>"

H = H + "<FORM name=""mask"">"

For conta = 1 To quanti

   H = H + campi(conta) + ": <input name=""" & campi(conta) & """  type=""text"" value=""" + valori(conta) + """><br>"

Next conta

H = H + "</FORM></body></html>"

IE.document.body.innerHTML = H

'

' Do While IE.readyState = 4: DoEvents: Loop

'

 Do While IE.readyState = 4

 '

    conta = 0

    For Each objtag In IE.document.all.tags("INPUT")

        conta = conta + 1

        ritorno(conta) = objtag.Value

 

    Next

 

  '

  DoEvents

  Loop

'

ritorno(0) = "risposta"

Set IE = Nothing

'

esci:

'

creamaskeraDef = ritorno

'

 

'

End Function

'

 

venerdì 2 marzo 2018

vba Excel evidenzia Prezzi Diversi Preventivi Ddt

‘ vba Excel evidenzia Prezzi Diversi Preventivi Ddt

 

Sub evidenziaPrezziDiversiPreventiviDdt()

Dim quanterighe, contarighe, foglio

Dim prezzopreve, prezzoddt, mesepreve, meseddt

Set foglio = Sheets("DDT-preventivi")

'

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

 

'

contarighe = 2

While contarighe <= quanterighe

      prezzopreve = foglio.Cells(contarighe, "j").Value

      prezzoddt = foglio.Cells(contarighe, "F").Value

      mesepreve = Month(foglio.Cells(contarighe, "r").Value)

      meseddt = Month(foglio.Cells(contarighe, "u").Value)

      If prezzopreve = prezzoddt Then   ' se il prezzo è uguale toglie la formattazione della cella

         foglio.Rows(contarighe).Interior.ColorIndex = xlNone

      Else

         If prezzoddt > prezzopreve Then ' se il prezzo del ddt è maggiore del preventivo

            If meseddt = mesepreve Then  ' verifica il mese del ddt e il mese preventivo corrispondano

               foglio.Rows(contarighe).Interior.ColorIndex = 46  ' evidenza la cella

            Else

                foglio.Rows(contarighe).Interior.ColorIndex = 8

            End If

         Else

            foglio.Rows(contarighe).Interior.ColorIndex = 6

         End If

      End If

      contarighe = contarighe + 1

Wend

'

End Sub

'