Sub stampa() Application.ScreenUpdating = False 'Sheets("Registro").Unprotect Password:="2208" 'Sheets("Archivio").Unprotect Password:="2208" 'Sheets("Servizio").Unprotect Password:="2208" 'Sheets("FATTURA INVERSA").Unprotect Password:="2208" 'Sheets("Database").Unprotect Password:="2208" With Sheets("Servizio2") riga = 2 While .Cells(riga, 2) <> "" riga = riga + 1 Wend Dim rng2 As Range Set sh3 = Sheets("Servizio2") sh3.Cells(riga, 2).Value = Range("G17").Value With Sheets("Registro") riga = 2 While .Cells(riga, 1) <> "" riga = riga + 1 Wend Dim Msg1, Msg2, Style1, Style2, Response Msg1 = "!!! VUOI MODIFICARE LA DATA PRIMA DI EMETTERE LA PARCELLA? !!! !!! PREMERE (SI) PER MODIFICARE !!! !!! PREMERE (NO) PER CONTINUARE !!! " Style1 = vbYesNo + vbCritical + vbDefaultButton1 Response = MsgBox(Msg1, Style1) If Response = vbYes Then Exit Sub Else End If Dim rng1 As Range Set sh1 = Sheets("Registro") Set sh3 = Sheets("Servizio2") Set sh4 = Sheets("Servizio") With ActiveSheet .Range("r3").Value = Application.WorksheetFunction.Max(Worksheets("Registro").Range("a2:a100")) + 1 End With sh1.Cells(riga, 1).Value = Range("R3").Value sh1.Cells(riga, 2).Value = Range("Q4").Value sh1.Cells(riga, 3).Value = Range("N11").Value sh1.Cells(riga, 4).Value = Range("N12").Value sh1.Cells(riga, 5).Value = Range("N13").Value sh1.Cells(riga, 6).Value = Range("O13").Value sh1.Cells(riga, 7).Value = Range("R13").Value sh1.Cells(riga, 8).Value = Range("N14").Value sh1.Cells(riga, 8).Value = Range("N14").Value sh1.Cells(riga, 9).Value = Range("M27").Value sh1.Cells(riga, 10).Value = Range("M25").Value sh1.Cells(riga, 11).Value = Range("M29").Value sh1.Cells(riga, 12).Value = Range("M33").Value sh1.Cells(riga, 13).Value = Range("M35").Value sh1.Cells(riga, 14).Value = Range("M38").Value With Sheets("Archivio") riga = 2 While .Cells(riga, 1) <> "" riga = riga + 1 Wend Set sh2 = Sheets("Archivio") With ActiveSheet .Range("r3").Value = Application.WorksheetFunction.Max(Worksheets("Registro").Range("a2:a100")) End With sh2.Cells(riga, 1).Value = Range("R3").Value sh2.Cells(riga, 2).Value = Range("Q4").Value sh2.Cells(riga, 3).Value = Range("N11").Value sh2.Cells(riga, 4).Value = Range("N12").Value sh2.Cells(riga, 5).Value = Range("N13").Value sh2.Cells(riga, 6).Value = Range("O13").Value sh2.Cells(riga, 7).Value = Range("R13").Value sh2.Cells(riga, 8).Value = Range("N14").Value sh2.Cells(riga, 8).Value = Range("N14").Value sh2.Cells(riga, 9).Value = Range("M27").Value sh2.Cells(riga, 10).Value = Range("M25").Value sh2.Cells(riga, 11).Value = Range("M29").Value sh2.Cells(riga, 12).Value = Range("M33").Value sh2.Cells(riga, 13).Value = Range("M35").Value sh2.Cells(riga, 14).Value = Range("M38").Value End With End With End With Dim percorso, nome, nomecompleto As String percorso = ActiveWorkbook.Path & "" nome = "PARCELLA_" & _ ActiveSheet.Range("R3").Text & "_" & Range("N11").Text & _ "_DEL_" & _ Replace(ActiveSheet.Range("Q4").Text, "/", "-") nomecompleto = percorso & nome & ".pdf" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nomecompleto _ , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _ :=False, OpenAfterPublish:=False Sheets("Archivio").Range("C2:C100,D2:D100,F2:F100,H2:H100").Copy Sheets("Database").Range("A2") Sheets("Database").Select Range("B2:B100").Select Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Set currentCell = Worksheets("Servizio").Range("B2") Do While Not IsEmpty(currentCell) Set nextCell = currentCell.Offset(1, 0) If nextCell.Value = currentCell.Value Then currentCell.EntireRow.Delete End If Set currentCell = nextCell Loop Range("B2").Select Sheets("Servizio2").Range("B2").Copy Sheets("Servizio").Range("A2") Application.Goto Sheets("Servizio").Range("B2") Sheets("Servizio").Activate Sheets("Servizio").Range("A2").Select Sheets("Servizio").Select 'Questo codice ordina i dati nella seconda 'colonna del Foglio1 ed elimina le righe che 'contengono dati duplicati (solo una riga e lascia l'altra con il dato trovato duplicato). Range("A2:D100").Select Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ DataOption1:=xlSortNormal Set currentCell = Worksheets("Database").Range("A2") Do While Not IsEmpty(currentCell) Set nextCell = currentCell.Offset(1, 0) If nextCell.Value = currentCell.Value Then currentCell.EntireRow.Delete End If Set currentCell = nextCell Loop Range("A2").Select Sheets("FATTURA INVERSA").Select Dim nVolte As Long, nQuante As Long Dim Partenza As Long, Appoggio As Long Dim messaggio As String, messaggio2 As String messaggio = "Digitare il N° di copie da stampare" On Error GoTo salta nQuante = InputBox(Prompt:=messaggio, Title:="Stampa") For nVolte = 1 To nQuante ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True Next Application.ScreenUpdating = False 'Sheets("Registro").Protect Password:="2208" 'Sheets("Archivio").Protect Password:="2208" 'Sheets("Servizio").Protect Password:="2208" 'Sheets("FATTURA INVERSA").Protect Password:="2208" 'Sheets("Database").Protect Password:="2208" Exit Sub salta: MsgBox "Non hai digitato il numero richiesto.", vbCritical 'Sheets("Registro").Protect Password:="2208" 'Sheets("Archivio").Protect Password:="2208" 'Sheets("Servizio").Protect Password:="2208" 'Sheets("FATTURA INVERSA").Protect Password:="2208" 'Sheets("Database").Protect Password:="2208" End Sub |