vba controlla e cancella righe duplicate e somma i valori

'

Option Explicit

'

' controlla e cancella righe duplicate e somma i valori

' esegue il controllo su due colonne, se entrambi i valori sono uguali

' somma gli importi presenti

'

Sub DueduplicaticancellaSomma()

'

Dim corrente1, corrente2, colonna1, colonna2, conta

Dim indietro, precedente1, precedente2, importo1, importo2, totale

'

Dim foglio, quanterighe, quantecolonne

'

Set foglio = Sheets("report")

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

'

Application.Cursor = xlWait

Application.ScreenUpdating = False

'

'

For conta = quanterighe To 1 Step -1                               ' conteggio righe usate

    corrente1 = Trim(ActiveSheet.Cells(conta, "B").Value)

    corrente2 = Trim(ActiveSheet.Cells(conta, "I").Value)

    importo1 = Trim(ActiveSheet.Cells(conta, "D").Value)

    indietro = conta - 1

    If indietro < 1 Then

       Exit For

    End If

    precedente1 = Trim(ActiveSheet.Cells(indietro, "B").Value)

    precedente2 = Trim(ActiveSheet.Cells(indietro, "I").Value)

    importo2 = Trim(ActiveSheet.Cells(indietro, "D").Value)

    If corrente1 = precedente1 Then

       If corrente2 = precedente2 Then

          If IsNumeric(importo1) = True And IsNumeric(importo2) = True Then

             totale = 0

             totale = CCur(importo1) + CCur(importo2)

             ActiveSheet.Cells(indietro, "D").Value = CCur(totale)

             totale = 0

          End If

          ActiveSheet.Rows(conta).Delete

       End If

    End If

'

Next conta

'

 

'

Application.ScreenUpdating = True

Application.Cursor = xlDefault

'

 

End Sub

 

 

ricerca parametri pseudo xml

'

'  ricerca parametri

'  gestione di un file parametri

'  ricerca tramite espressione regolare.

'  il file parametri ha la struttura similare ad  un file xml.

'  utilizzato per sopperire alle incoerenza dei file xml che non posso contenere tag numerici,

'

option explicit

'

dim htmlrisposta

'

htmlrisposta = cercaParametrihtml(182, "natura")

'

msgbox "finale: " & htmlrisposta

'

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

'

'

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

'

Function informazioni(precord, pcampo)

dim parchivio, strHTML

parchivio= '"C:\lavoro-2016\db-informazioni.xml"

parchivio= dbinformazioni

dim filesys, readfile, jtxt

set filesys = CreateObject ("Scripting.FileSystemObject")

 

If (filesys.FileExists(parchivio)) Then

      'msg = filespec & " esiste."

       set readfile = filesys.OpenTextFile(parchivio, 1, false)

       strHTML = readfile.ReadAll

Else

      'msg = filespec & " Non esiste."

       Set readfile = filesys.CreateTextFile(pArchivio, TRUE)

       '

       jtxt = "<vuoto>mancano paramenti</vuoto>"

       readfile.WriteLine(jtxt)

       strHTML = jtxt

End If

'

readfile.close

'

dim oRegex, criterio, trovatocampo, trovatorecord

set oRegex = CreateObject("vbscript.regexp")

oRegex.Global = 1

oRegex.Multiline = 1

oRegex.IgnoreCase = 1

'

trovatocampo = ""

trovatorecord = ""

' ----

criterio = "<" & precord & ">((?:.|\n|\r)*?)</" &  precord & ">"

'

oRegex.Pattern = criterio

If oRegex.Test(strHTML) = true Then

   trovatorecord = oRegex.Execute(strHTML).item(0).SubMatches.item(0)

else

   trovatorecord = ""

end if

' ---

criterio = "<" & pcampo & ">((?:.|\n|\r)*?)</" &  pcampo & ">"

'

oRegex.Pattern = criterio

If oRegex.Test(trovatorecord) = true Then

   trovatocampo = oRegex.Execute(trovatorecord).item(0).SubMatches.item(0)

else

   trovatocampo = ""

end if

'

informazioni = trovatocampo

'

end Function

'

'=====

'

‘

‘ esempio del file db-informazioni.xml

‘

<fatturaelettronica>

 

<dadef1>

 <natura>N1</natura>

 <RiferimentoNormativo>RiferimentoNormativo</RiferimentoNormativo> 

 <agenzia> N1 escluse ex art. 15 <agenzia>

</dadef1>

 

<dadef2>

 <natura>N2</natura>

 <RiferimentoNormativo>RiferimentoNormativo</RiferimentoNormativo> 

 <agenzia> N2 non soggette <agenzia>

</dadef2>

 

<182>

 <natura>N3</natura>

 <RiferimentoNormativo>Non imponibile per dichiarazione di intento art 8 2c dpr 633-72</RiferimentoNormativo>

 <agenzia>N3 non imponibili </agenzia>

</182>

 

<dadef3>

 <natura>N4</natura>

 <RiferimentoNormativo>RiferimentoNormativo</RiferimentoNormativo> 

 <agenzia> N4 esenti  <agenzia>

</dadef3>

 

<dadef4>

 <natura>N5</natura>

 <RiferimentoNormativo>RiferimentoNormativo</RiferimentoNormativo> 

 <agenzia> N5 regime del margine  <agenzia>

</dadef4>

 

<dadef5>

 <natura>N6</natura>

 <RiferimentoNormativo>RiferimentoNormativo</RiferimentoNormativo> 

 <agenzia> N6 inversione contabile (reverse charge)  <agenzia>

</dadef5>

 

 

 

</fatturaelettronica>

 

vba Crea Link Valori Foglio

'

Option Explicit

'

Sub CreaLinkValoriFoglio()

' vba - crea collegamenti incrociati tra due fogli.

'

' esempio di come è stata ottenuta la riga di riferimento, ecco la formula

'   ActiveCell.FormulaR1C1 = "=MATCH(RC[-4],studio!C[-12],0)"

'

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

Dim indirizzostudio, indirizzoazienda

'

Dim sfoglio

Set foglio = Sheets("azienda")

Set sfoglio = Sheets("studio")

'

Dim colonnaazienda, colonnastudio, colonnastudioritornoazienda

colonnaazienda = "P" '  colonna in cui si trova il numero

colonnastudio = "D"

colonnastudioritornoazienda = "F" ' colonna del foglio studio in cui scrivere il link di ritorno al foglio azienda

'

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

'

contarighe = 2

While contarighe <= quanterighe

      contenuto = foglio.Cells(contarighe, colonnaazienda).Value ' la cella contiene il numero riga del foglio in cui si trova il valore

      If Len(Trim(contenuto)) > 0 Then

         indirizzoazienda = "azienda!" & foglio.Cells(contarighe, colonnaazienda).Address

         indirizzostudio = "studio!" & sfoglio.Cells(contenuto, colonnastudio).Address

         foglio.Activate

         foglio.Cells(contarighe, colonnaazienda).Activate

         ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _

           indirizzostudio, TextToDisplay:=indirizzostudio

         sfoglio.Activate

         sfoglio.Cells(contenuto, colonnastudioritornoazienda).Activate

           ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _

           indirizzoazienda, TextToDisplay:=indirizzoazienda

      End If

     contarighe = contarighe + 1

Wend

'

'

End Sub

'

 

vbs - esegue programma in base ad un dizionario del numero dei mesi

'

option explicit

'

' vbs - esegue programma in base ad un dizionario del numero dei mesi

'

dim giornomese

giornomese = day(date)   ' dalla data odierna prende il giorno

'

'

dim programma ' programma da eseguire

programma = "C:\sell-in\report-sell-in.vbs"

'

Dim d, valore

Set d = CreateObject("Scripting.Dictionary")

' SI = esegue il programma

d.Add "1", "NO"

d.Add "2", "NO"

d.Add "3", "NO"

d.Add "4", "NO"

d.Add "5", "NO"

d.Add "6", "NO"

d.Add "7", "NO"

d.Add "8", "NO"

d.Add "9", "NO"

d.Add "10", "NO"

d.Add "11", "NO"

d.Add "12", "NO"

d.Add "13", "NO"

d.Add "14", "SI"

d.Add "15", "SI"

d.Add "16", "SI"

d.Add "17", "NO"

d.Add "18", "NO"

d.Add "19", "NO"

d.Add "20", "NO"

d.Add "21", "NO"

d.Add "22", "NO"

d.Add "23", "NO"

d.Add "24", "NO"

d.Add "25", "NO"

d.Add "26", "NO"

d.Add "27", "NO"

d.Add "28", "NO"

d.Add "29", "NO"

d.Add "30", "NO"

d.Add "31", "NO"

'

' recupera il valore abbinato a numero del mese

valore = d.Item(CSTR(giornomese))

'

Dim WshShell, esegui, attesa

Set WshShell = CreateObject("WScript.Shell")

'

if valore = "SI" then

   esegui = programma

   attesa = WshShell.Run (esegui, 1, true)

end if

'

'

 

vba verifica esistenza file per un determinato giorno della settimana

Option Explicit

'

Public Const cartellafile = "C:\Users\Downloads\"

'

' vba verifica esistenza file per un determinato giorno della settimana

'

Sub VerificaEsistenzaFileDataGiorno()

Dim quanterighe, contarighe, foglio, contenuto, colonnadaleggere, giorno, sfile

Set foglio = Sheets(ActiveSheet.Name)

'

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

colonnadaleggere = "A"

'

contarighe = 2

While contarighe <= quanterighe

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

      If IsDate(contenuto) = True Then

         giorno = settimanaNomeGiorno(contenuto)

         If giorno = "domenica" Then

            foglio.Cells(contarighe, "B").Value = "x"

            sfile = cartellafile & dataansi(contenuto) & ".txt"

            If esistefile(sfile) = "si" Then

                foglio.Cells(contarighe, "c").Value = "esiste"

            Else

                foglio.Cells(contarighe, "c").Value = "NON esiste"

            End If

         End If

      End If

      contarighe = contarighe + 1

Wend

'

'

End Sub

'

'

'

Function esistefile(parchivio)

Dim fs

Set fs = CreateObject("Scripting.FileSystemObject")

If fs.FileExists(parchivio) = True Then

   esistefile = "si"

Else

   esistefile = "no"

End If

Set fs = Nothing

End Function

'

'

'

Function dataansi(pdata)

Dim sdata

sdata = Year(pdata)

sdata = sdata & Month(pdata)

sdata = sdata & Day(pdata)

dataansi = sdata

'

End Function

'

'

'

Function settimanaNomeGiorno(dt)

Dim NomeGiorno 'As String

Select Case Weekday(dt, 1)

      Case 1: NomeGiorno = "domenica" ' "Sun"

      Case 2: NomeGiorno = "lunedi'" ' "Mon"

      Case 3: NomeGiorno = "martedi'" ' "Tue"

      Case 4: NomeGiorno = "mercoledi'" ' "Wed"

      Case 5: NomeGiorno = "giovedi'" ' "Thu"

      Case 6: NomeGiorno = "venerdi'" ' "Fri"

      Case 7: NomeGiorno = "sabato" ' "Sat"

End Select

 

settimanaNomeGiorno = NomeGiorno

 

End Function

'

 

 

'

vbs - scrive dati foglio Excel in file csv per stampa mailmerge etichette in Word

'

' vbs - scrive dati foglio Excel in file csv per stampa mailmerge etichette in Word

'

Sub ScriviFoglioCsvSql()

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

'

Dim cartellafile, fs, a, archivio, stesto, nomefile

cartellafile = "C:\etichette-csv\"

nomefile = "etichette-" & Format(Now(), "yyyymmddmms") & ".txt" ' & ".csv"

archivio = cartellafile & nomefile

'

'

Set fs = CreateObject("Scripting.FileSystemObject")

Set a = fs.CreateTextFile(archivio, True)

'

Set foglio = Sheets(ActiveSheet.Name)

'

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

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

'

quantecolonne = 6

'

contarighe = 1

While contarighe <= quanterighe

   contacolonne = 1

   stesto = ""

   While contacolonne <= quantecolonne

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

      contenuto = Replace(contenuto, ";", " ")

      contenuto = contenuto & ";"

      stesto = stesto & contenuto

      contacolonne = contacolonne + 1

   Wend

   '

   a.WriteLine (stesto)

   '

   contarighe = contarighe + 1

Wend

'

a.Close

'

Dim cartella, documento, nomedoc

cartella = "C:\etichette-csv\"

documento = cartella & "b-etichette-105x37 - Copia.doc"

'

Dim oApp, wdDoc

'

Set oApp = CreateObject("Word.Application")

oApp.Visible = True

'

Set wdDoc = oApp.Documents.Open(documento)

'

With oApp

    nomedoc = .ActiveDocument.Name

   .Activate

   .Documents(nomedoc).Activate  ' setta il riferimento al documento

End With

'

 wdDoc.MailMerge.OpenDataSource Name:= _

        archivio, ConfirmConversions:=False, _

        ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _

        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _

        WritePasswordTemplate:="", Revert:=False, Format:=0, _

        Connection:="", SQLStatement:="", SQLStatement1:="", SubType:=0

 

  wdDoc.MailMerge.Execute

'

oApp.Documents(documento).Close SaveChanges:=wdDoNotSaveChanges

'

End Sub

'

'

salva allegati pdf dei messaggi di posta elettronica

'

option explicit

'

dim cartellaprg

cartellaprg = "C:\azioniprogrammate\allegati-posta-oggetto-fattura\"

dim prg1, prg2, prg3, prg4

prg1 = cartellaprg & "prg-010-salva-allegati-cartelle-pubbliche-oggetto-fattura.vbs"

prg2 = cartellaprg & "prg-020-converti-in-testo.vbs"

prg3 = cartellaprg & "prg-030-elenca-file-cartella.vbs"

prg4 = cartellaprg & "prg-040-cancella-file-messaggi.vbs"

'

dim prgemaildaarchiviodigitale, prgdominidaarchiviodigitale

prgemaildaarchiviodigitale = "C:\azioniprogrammate\archivio-digitale-fatture-2018\p02-cartelle-archivio-digitale.vbs"

prgdominidaarchiviodigitale  = "C:\azioniprogrammate\archivio-digitale-fatture-2018\p03-elenco-domini.vbs"

'

dim prgriferimentipartitaiva

prgriferimentipartitaiva = "C:\azioniprogrammate\salva-allegati-posta-piva\p02-cartelle-archivio-digitale.vbs"

'

' = verifica che outlook sia attivo

'

dim sprocesso, presente, trovato

dim sComputerName, objWMIService, sQuery, objItems, objItem

trovato = 0

'This function can report names from

'TaskManager -> Processes

    sComputerName = "."

    Set objWMIService = GetObject("winmgmts:\\" & sComputerName & "\root\cimv2")

    sQuery = "SELECT * FROM Win32_Process"

    Set objItems = objWMIService.ExecQuery(sQuery)

    'iterate all item(s)

    For Each objItem In objItems

        sprocesso = objItem.Name

        presente = instr(lcase(sprocesso), "outlook.exe")

        if presente > 0 then

           trovato = 1

           exit for

        else

           trovato = 0 

        end if

    Next

'

if trovato = 0 then

   'msgbox "outlook NON attivo"

else

  ' msgbox "outlook attivo"

  call prgrammasalvaallegati 

end if

'

'   =====

'

sub prgrammasalvaallegati()

Dim WshShell, esegui, attesa

Set WshShell = CreateObject("WScript.Shell")

'

' - salva allegati da exchange - stampa, in pdf, i messaggi

'

esegui = prg1

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgemaildaarchiviodigitale

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgdominidaarchiviodigitale

attesa = WshShell.Run (esegui, 1, true)

'

esegui = prgriferimentipartitaiva

attesa = WshShell.Run (esegui, 1, true)

'

' - converte in testo allegati pdf e i messaggi di posta

'

esegui = prg2

attesa = WshShell.Run (esegui, 1, true)

'

' cerca la partita, e poi cerca con indirizzo email

'

esegui = prg3

attesa = WshShell.Run (esegui, 1, true)

'

' cancella file temporanei

'

esegui = prg4

attesa = WshShell.Run (esegui, 1, true)

end sub

'

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

'

vbscript - filtra un file di testo utilizzando espressioni regolari

'

option explicit

'

' vbs - filtra un file di testo utilizzando espressioni regolari

'

dim objArgs, Filename, cartellalavori, Title

'

Set objArgs = WScript.Arguments  'Vedo se ci sono degli argomenti passati allo script

if objargs.count=0 then  'altrimenti mostro come si usa il programma

            msgbox "Trascinare un file sul programma per visualizzarlo", vbinformation+vbokonly, Title

            wscript.quit

end if

'

Filename=wscript.arguments(0)

'

cartellalavori = fcartellalavori(Filename)

'

dim dblog, slog

dblog = cartellalavori & "esito-1.txt"

call cancellafile(dblog)

'

dim criterioricerca

 criterioricerca = "[ ]{3,}"   ' solo righe con tre spazi consecutivi

' criterioricerca = "^\w{3}\s+\w*"

' criterioricerca = "^\w+\s\w+"

 

'

call leggifile(FileName)

'

FileName = dblog

dblog = cartellalavori & "esito-2.txt"

call cancellafile(dblog)

criterioricerca = "^\w+\s\w+"

call leggifile(FileName)

'

 

'

' ===

'

sub leggifile(pFileName)

dim  objFSO, objFile, text, txtStream

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

'

If objFSO.FileExists(pFilename) = true Then   

   Set txtStream = objFSO.OpenTextFile(pFilename) ' Apre file di testo.

   Do While Not (txtStream.atEndOfStream)      

       Text = txtStream.ReadLine 'legge una riga  

'

       call TestRegExp(criterioricerca, text)

'

  Loop

End If

'

'

end sub

'

'  =====

'

function fcartellalavori(pfile) ' determina la cartella di origine del file

dim  objFSO, objFile

'

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFile = objFSO.GetFile(pfile)

'

fcartellalavori = objFSO.GetParentFolderName(objFile)  & "\"

'

'

end function

'

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

'

Sub TestRegExp(sPattern, ptesto)

'

dim sSearch

sSearch = ptesto

'

Dim oRE, oMatches, oMatch

Set oRE = CreateObject("VBScript.RegExp")

oRE.Global = True

oRE.IgnoreCase = True

oRE.Pattern = sPattern

if oRe.Test(sSearch) = true then

   Set oMatches = oRE.Execute(sSearch)

   For Each oMatch In oMatches

       ' msgbox oMatch.value

       ' stesto = stesto & oMatch.FirstIndex & " : " &  oMatch.Length  & " : " & oMatch.value & vbcrlf

       slog = ptesto

       '

       call ScriviFileJollyAppend(dblog, ptesto)

   Next

end if

'

'

End Sub

'

' =======

'

sub cancellafile(pfile)

dim fs

Set fs=CreateObject("Scripting.FileSystemObject")

if fs.FileExists(pfile) then

   fs.DeleteFile(pfile)

end if

set fs=nothing

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

'

' =========

'