Home › Forum › Domande su Excel VBA e MACRO › Errore di Run-time 438 › Rispondi a: Errore di Run-time 438
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 IfSet ws1 = Nothing
Set ws2 = Nothing
Application.ScreenUpdating = True
End SubLa 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
`