- By Sal Excel & VBA

antino

Partecipante

17 Maggio 2020 alle 11:19

Post totali: 38

#10049

Ciao By Sal,

Questa è l’intera macro utilizzata (Sub RegiostraAvvisoParcella)
questa è la macro utilizzata:

Sub RegistraAvvisoParcella()

‘===========================================================
‘BISOGNA ATTIVARE LA LIBRERIA
‘”Microsoft Visual Basic For Applications Extensibility 5.3″
‘===========================================================

Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim wb As Workbook
Dim VbComp As VBIDE.VBComponent
Dim NOMEFILE As String
Dim UserName As String
Dim ANNO As Integer
Dim Percorso As String
Dim cartella
Dim sovrascrivo As VbMsgBoxResult
Dim iRow As Integer
Dim foglio As String
Dim NOMEFILE1 As String
ANNO = Year(Date)

‘ On Error GoTo uscita
Set ws1 = ThisWorkbook.Sheets(“INS. AVV. PARCELLA”)
Set ws2 = ThisWorkbook.Sheets(“Avvisi Parcella”)

Percorso = “L:\FATTURAZIONE\” & ANNO & “\AVVISI PARCELLA\”
cartella = Dir(Percorso, vbDirectory)

‘ STAMPO IL FOGLIO
ExecuteExcel4Macro “PRINT(2,1,1,2,,,,,,,,2,,,TRUE,,FALSE)”

‘COPIO IL FOGLIO IN UN NUOVO FILE
ws1.Unprotect
ws1.Copy

‘ELIMINO TUTTE LE MACRO CON ANNESSI MODULI, FORM E MODULI DI CLASSE
For Each VbComp In ActiveWorkbook.VBAProject.VBAComponents
Select Case VbComp.Type
Case 1 To 3
ActiveWorkbook.VBProject.VBComponents.Remove VbComp
Case Else
With VbComp.CodeModule
.DeleteLines 1, .CountOfLines
End With
End Select
Next VbComp

‘FORMATTO IL FOGLIO SOLO CON I VALORI
Set wb = ActiveWorkbook
With wb.Sheets(“1”)
.Columns(“I:N”).Delete
.Range(“A1:H44”).Copy
.Range(“A1”).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.Range(“A1”).Select
.Name = “Avviso Parcella”
UserName = .Range(“C18”).Value
.PageSetup.PrintArea = “A1:H44”
End With

NOMEFILE = “Avviso di Parcella n. ” & UserName & “.xls”
NOMEFILE1 = “Avviso di Parcella n. ” & UserName & “.pdf”

‘VERIFICO CHE NELLA DIRECTORY DI SALVATGGIO NON ESISTA
‘UN FILE CON LO STESSO NOME DI QUELLO CHE SALVERò
Do While cartella <> “”
If cartella <> “.” And cartella <> “..” Then
If NOMEFILE = cartella Then
sovrascrivo = MsgBox(“Esiste già un file con lo stesso nome; ” & _
“sovrascriverlo?”, vbYesNo + vbExclamation, “ATTENZIONE”)
If sovrascrivo = vbNo Then
MsgBox “Il file corrente verrà chiuso senza essere salvato” _
, vbInformation, “CHIUSURA FILE”
Application.DisplayAlerts = False
wb.Close
Application.DisplayAlerts = True
Exit Sub
End If
Exit Do
End If
End If
cartella = Dir
Loop

‘SALVO IL FILE E LO CHIUDO
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Percorso & NOMEFILE1
wb.SaveAs Filename:=Percorso & NOMEFILE, FileFormat:=xlExcel8
Application.DisplayAlerts = True
wb.Close
MsgBox “File salvato con successo”, vbInformation _
, “SALVATAGGIO FILE”
Set wb = Nothing
foglio = ws1.Range(“N1”)

‘APRO IL FILE “Schede Clienti.xlsm” E CI COPIO I DATI
‘DEL FOGLIO “INS. AVV. PARCELLA”; LO SALVO E LO CHIUDO
Set wb = Workbooks.Open(“L:\FATTURAZIONE\Schede Clienti.xlsm”)
With wb.Worksheets(foglio)
iRow = 3
While .Cells(iRow, 2).Value <> “”
iRow = iRow + 1
Wend
ws1.Range(“C18”).Copy
.Cells(iRow, 1).PasteSpecial Paste:=xlPasteValues
ws1.Range(“G18”).Copy
.Cells(iRow, 2).PasteSpecial Paste:=xlPasteValues
ws1.Range(“A22”).Copy
.Cells(iRow, 3).PasteSpecial Paste:=xlPasteValues
ws1.Range(“H39”).Copy
.Cells(iRow, 4).PasteSpecial Paste:=xlPasteValues
‘ .Range(“A1”).Activate
wb.Save
wb.Close
End With
Set wb = Nothing

MsgBox “Registrato scheda cliente con successo”, vbInformation

iRow = 2
While ws2.Cells(iRow, 2).Value <> “”
iRow = iRow + 1
Wend

‘COPIO I DATI DAL FOGLIO “INS. AVV. PARCELLA” AL FOGLIO “Avvisi Parcella”
ws2.Cells(iRow, 1).Value = ws1.Cells(18, 3).Value ‘Numero Avviso Parcella
ws2.Cells(iRow, 2).Value = ws1.Cells(18, 7).Value ‘Data Avviso Parcella
ws2.Cells(iRow, 3).Value = ws1.Cells(12, 7).Value ‘Nominativo Cliente
ws2.Cells(iRow, 4).Value = ws1.Cells(39, 8).Value ‘Importo Totale A. Parcella

‘ORDINI I DATI COPIATI
ws2.Sort.SortFields.Clear
ws2.Sort.SortFields.Add Key:=ws2.Range(“A2:A501”), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With ws1.Sort
.SetRange ws2.Range(“A2:D501”)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets(“INS. AVV. PARCELLA”).Protect
Sheets(“MENU PRINCIPALE”).Select
MsgBox “Copia dei dati effettuata con successo”, vbInformation

‘ INVIO L’AVVISO DI PARCELLA EMESSO CON ESTENZIONE PDF TRAMITE E-MAIL ALL’INDIRIZZO DEL CLIENTE
Dim Msg, Style, Title, Response, MyString
Msg = “Ora sarà possibile, con uma e-mail, inviare il file generato! Continuare?” ‘ Definisce il messaggio.
Style = vbYesNo + vbInformation + vbDefaultButton2 ‘ Definisce i pulsanti.
Title = “Avviso di Parcella” ‘ Definisce il titolo.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then

Dim Indirizzo As String
Dim IndirizzoCc As String
Dim IndirizzoBcc As String
Dim oggetto As String
Dim testo As String

Indirizzo = ws1.Range(“O1”) ‘<——qui ci scrivi l’indirizzo oppure la cella excel oppure il controllo (combobox, textbox, ecc) di ‘riferimento.
IndirizzoCc = ws1.Range(“O2”)
IndirizzoBcc = ws1.Range(“O3”)
oggetto = “Invio Avviso di Parcella” ‘Me.TextBox1
testo = “Si allega alla presente l’Avviso di Parcella emesso” ‘Me.TextBox2
‘If Me.ComboBox1 = “” Or Me.TextBox1 = “” Or Me.TextBox2 = “” Then
‘MsgBox “Devi riempire tutti i campi”, vbExclamation
‘Else

Dim OutApp As Object
Dim OutMail As Object
Dim bodymail As String

Set OutApp = CreateObject(“Outlook.Application”)
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With OutMail
‘.From = “” ‘tuo indirizzo mail”
.To = Indirizzo
.CC = IndirizzoCc
.BCC = IndirizzoBcc
.Subject = oggetto
.bodyformat = olFormatHTML
bodymail = “<html><head></head><body>”
.HTMLBody = bodymail + testo
.Attachments.Add Percorso + NOMEFILE1
.Display
‘.Send ‘ Per inviare direttamente la mail al posto di .display

End With
Set OutMail = Nothing
Set OutApp = Nothing
MsgBox “mail inviata !”

End If

‘SOLITA GESTIONE DELL’ERRORE
‘ uscita:
‘ If Err.Number <> 0 Then
‘ MsgBox Err.Description
‘ End If

Set ws1 = Nothing
Set ws2 = Nothing
Application.ScreenUpdating = True
End Sub

La cosa strana che quest’altra macro (per alcuni passaggi identica) non mi da alcun problema:

Sub RegistraParcella()

'===========================================================
'BISOGNA ATTIVARE LA LIBRERIA
'"Microsoft Visual Basic For Applications Extensibility 5.3"
'===========================================================

Application.ScreenUpdating = False
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim wb As Workbook
Dim VbComp As VBIDE.VBComponent
Dim NOMEFILE As String
Dim UserName As String
Dim ANNO As Integer
Dim Percorso As String
Dim cartella
Dim sovrascrivo As VbMsgBoxResult
Dim iRow As Integer
Dim foglio As String
Dim NOMEFILE1 As String

' On Error GoTo uscita
Set ws1 = ThisWorkbook.Sheets("INS. PARCELLA")
Set ws2 = ThisWorkbook.Sheets("Parcelle")
ANNO = Year(Date)
Percorso = "C:\FATTURAZIONE\" & ANNO & "\PARCELLE\"
cartella = Dir(Percorso, vbDirectory)

'STAMPO IL FOGLIO
ExecuteExcel4Macro "PRINT(2,1,1,2,,,,,,,,2,,,TRUE,,FALSE)"

'COPIO IL FOGLIO IN UN NUOVO FILE
ws1.Unprotect
ws1.Copy

'ELIMINO TUTTE LE MACRO CON ANNESSI MODULI, FORM E MODULI DI CLASSE
For Each VbComp In ActiveWorkbook.VBProject.VBComponents
   Select Case VbComp.Type
      Case 1 To 3
         ActiveWorkbook.VBProject.VBComponents.Remove VbComp
      Case Else
         With VbComp.CodeModule
            .DeleteLines 1, .CountOfLines
         End With
   End Select
Next VbComp

'FORMATTO IL FOGLIO SOLO CON I VALORI
Set wb = ActiveWorkbook
With wb.Sheets(1)
   .Columns("I:N").Delete
   .Range("A1:H44").Copy
   .Range("A1").PasteSpecial Paste:=xlPasteValues
   Application.CutCopyMode = False
   .Range("A1").Select
   .Name = "Parcella"
    UserName = .Range("C18").Value
    .PageSetup.PrintArea = "A1:H44"
End With

NOMEFILE = "Parcella n. " & UserName & ".xls"
NOMEFILE1 = "Parcella n. " & UserName & ".pdf"

'VERIFICO CHE NELLA DIRECTORY DI SALVATGGIO NON ESISTA
'UN FILE CON LO STESSO NOME DI QUELLO CHE SALVER?
Do While cartella <> ""
    If cartella <> "." And cartella <> ".." Then
         If NOMEFILE = cartella Then
            sovrascrivo = MsgBox("Esiste gi? un file con lo stesso nome; " & _
            "sovrascriverlo?", vbYesNo + vbExclamation, "ATTENZIONE")
            If sovrascrivo = vbNo Then
                MsgBox "Il file corrente verr? chiuso senza essere salvato" _
                , vbInformation, "CHIUSURA FILE"
                Application.DisplayAlerts = False
                wb.Close
                Application.DisplayAlerts = True
                Exit Sub
            End If
            Exit Do
         End If
    End If
   cartella = Dir
Loop
    
'SALVO IL FILE E LO CHIUDO
Application.DisplayAlerts = False
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Percorso & NOMEFILE1
wb.SaveAs Filename:=Percorso & NOMEFILE, FileFormat:=xlExcel8
Application.DisplayAlerts = True
wb.Close
MsgBox "File salvato con successo", vbInformation _
, "SALVATAGGIO FILE"
Set wb = Nothing
foglio = ws1.Range("N1")

'APRO IL FILE "Schede Clienti.xlsm" E CI COPIO I DATI
'DEL FOGLIO "INS. PARCELLA"; LO SALVO E LO CHIUDO
Set wb = Workbooks.Open("C:\FATTURAZIONE\Schede Clienti.xlsm")
With wb.Worksheets(foglio)
    iRow = 3
    While .Cells(iRow, 6).Value <> ""
        iRow = iRow + 1
    Wend
    ws1.Range("C18").Copy
    .Cells(iRow, 5).PasteSpecial Paste:=xlPasteValues
    ws1.Range("G18").Copy
    .Cells(iRow, 6).PasteSpecial Paste:=xlPasteValues
    ws1.Range("H39").Copy
    .Cells(iRow, 7).PasteSpecial Paste:=xlPasteValues
    ' .Range("A1").Activate
    wb.Save
    wb.Close
End With
Set wb = Nothing

MsgBox "Registrato scheda cliente con successo", vbInformation
      
iRow = 2
While ws2.Cells(iRow, 2).Value <> ""
    iRow = iRow + 1
Wend

'COPIO I DATI DAL FOGLIO "INS. PARCELLA" AL FOGLIO "Parcelle"
ws2.Cells(iRow, 1).Value = ws1.Cells(18, 3).Value 'Numero Parcella
ws2.Cells(iRow, 2).Value = ws1.Cells(18, 7).Value 'Data Parcella
ws2.Cells(iRow, 3).Value = ws1.Cells(12, 7).Value 'Nominativo Cliente
ws2.Cells(iRow, 4).Value = ws1.Cells(39, 8).Value 'Importo Totale Parcella
ws2.Cells(iRow, 5).Value = ws1.Cells(39, 6).Value 'Importo Rittenuta d'Acconto
    
'ORDINI I DATI COPIATI
ws2.Sort.SortFields.Clear
ws2.Sort.SortFields.Add Key:=ws2.Range("A2:A501"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With ws1.Sort
    .SetRange ws2.Range("A2:D501")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
    End With
ws1.Protect

'IMPLEMENTO CODICE COLORAZIONE RIGA
Dim area As Range
Dim cella As Range
Dim Navviso As Variant
Dim ws3 As Worksheet
Set ws3 = ThisWorkbook.Sheets("Avvisi Parcella")
Navviso = ws1.Cells(2, 12).Value

Set area = ws3.Range("A:A")
Set cella = area.Find(Navviso, , xlValues)
If Not cella Is Nothing Then
    ws3.Range("A" & cella.Row, "D" & cella.Row).Interior.ColorIndex = 6
End If

Sheets("MENU PRINCIPALE").Select
MsgBox "Copia dei dati effettuata con successo", vbInformation

' INVIO LA PARCELLA EMESSA CON ESTENZIONE PDF TRAMITE E-MAIL ALL'INDIRIZZO DEL CLIENTE
Dim Msg, Style, Title, Response, MyString
Msg = "Ora sar? possibile, con uma e-mail, inviare il file generato! Continuare?"  ' Definisce il messaggio.
Style = vbYesNo + vbInformation + vbDefaultButton2    ' Definisce i pulsanti.
Title = "Avviso"    ' Definisce il titolo.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then

Dim Indirizzo As String
Dim IndirizzoCc As String
Dim IndirizzoBcc As String
Dim oggetto As String
Dim testo As String

Indirizzo = ws1.Range("O1")   '<------qui ci scrivi l'indirizzo oppure la cella excel oppure il controllo (combobox, textbox, ecc) di  'riferimento.
IndirizzoCc = ws1.Range("O2")
IndirizzoBcc = ws1.Range("O3")
oggetto = "Invio Parcella"  'Me.TextBox1
testo = "Si allega alla presente fattura emessa" 'Me.TextBox2
'If Me.ComboBox1 = "" Or Me.TextBox1 = "" Or Me.TextBox2 = "" Then
'MsgBox "Devi riempire tutti i campi", vbExclamation
'Else

Dim OutApp As Object
Dim OutMail As Object
Dim bodymail As String

        Set OutApp = CreateObject("Outlook.Application")
        OutApp.Session.Logon
        Set OutMail = OutApp.CreateItem(0)
    
        With OutMail
            '.From = "" 'tuo indirizzo mail"
            .To = Indirizzo
            .CC = IndirizzoCc
            .BCC = IndirizzoBcc
            .Subject = oggetto
            .bodyformat = olFormatHTML
            bodymail = "<html><head></head><body>"
            .HTMLBody = bodymail + testo
            .Attachments.Add Percorso + NOMEFILE1
            .Display
            '.Send  ' Per inviare direttamente la mail al posto di .display
            
         End With
    Set OutMail = Nothing
Set OutApp = Nothing
MsgBox "mail inviata !"
End If

'SOLITA GESTIONE DELL'ERRORE
' uscita:
' If Err.Number <> 0 Then
'    MsgBox Err.Description
' End If

Set ws1 = Nothing
Set ws2 = Nothing
Set area = Nothing
Set cella = Nothing
Set ws3 = Nothing

Application.ScreenUpdating = True
End Sub

Grazie dell’aiuto