You are here:Home-Domande su Excel VBA e MACRO-Errore di Run-time 438-Rispondi a: Errore di Run-time 438
Rispondi a: Errore di Run-time 4382020-05-17T11:19:02+02:00

Home Forum Domande su Excel VBA e MACRO Errore di Run-time 438 Rispondi a: Errore di Run-time 438

antinoantino
Partecipante
    Post totali: 38

    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

    `