Eva Kant
2018-11-23 12:05:45 UTC
Buongiorno,
ho una macro che analizza il valore della colonna d (da d13 a d6xx): se ha il valore yes, fa una serie di operazioni aggiorna il foglio e poi lo esporta in pdf.
Di conseguenza ho n pdf in base a quanti yes ci sono.
Ora avrei bisogno che la macro possa generare anche un unico pdf.
Avevo pensato di sfruttare l'opzione "workbook" ossia se nell'ultima cella scrivo workbook lei (la macro) mi genera anche il pdf globale.
Avevo pensato di fare un copia valori del foglio aggiornato, ma mi sono persa.
Potete aiutarmi?
Grazie mille
Vi copio la macro attuale, che funziona.
Claudia
Sub CreazionePDFnew_V2() 'Funziona ma non c'è la creazione di un unico pdf per la stampa
Dim ShArr() As String, FArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
Dim wb As Workbook, sh As Worksheet
Dim wbINuso As Workbook
Dim DefPath As String
Dim FileExtStr As String
'
Dim StringFileNames As String
Dim StringSheetNames As String
Dim FileNamesArray As Variant
Dim SheetNamesArray As Variant
Dim I As Long, S As Long, F As Long
Dim WrongData As Boolean
'
'Set folder where we save the temporary files
DefPath = [N1] '"A:\Scansioni\" '*
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
' -------- Da DECOMMENTARE
With Application
' .ScreenUpdating = False
' .EnableEvents = False
End With
Set wbINuso = ActiveWorkbook
nCelle = Cells(Rows.Count, "d").End(xlUp).Row
Set rng = Range("d13:" & "d" & nCelle) 'automatizzato con il range variabile
For Each myCell In rng
If LCase(myCell.Value) = "yes" Then
S = 0: F = 0
Erase ShArr: Erase FArr
'Set Error Boolean to False
WrongData = False
'
Range("C9").Value = ActiveSheet.Cells(myCell.Row, "c")
Range("B1").Value = ActiveSheet.Cells(myCell.Row, "a")
Range("c1").Value = ActiveSheet.Cells(myCell.Row, "b")
' Calculate
'Check if there are Sheet names in column B
'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
If Trim(ActiveSheet.Cells(myCell.Row, "d").Value) = "" Then S = 0
'If there are sheet names in the B column S is the number of sheets it add to the Array
If LCase(Trim(ActiveSheet.Cells(myCell.Row, "d").Value)) <> "workbook" Then 'era B
StringSheetNames = ActiveSheet.Cells(8, "L").Value 'era q
SheetNamesArray = Split(StringSheetNames, Chr(10), -1)
If SheetNamesArray(I) <> "" Then
S = S + 1
ReDim Preserve ShArr(1 To S)
ShArr(S) = SheetNamesArray(I)
End If
On Error GoTo 0
Else
'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
S = -1
End If
'Create PDF
'Create Date/time string for the file name
strDate = Format(Now, "yyyy.mm") 'Originale: strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")
'
'Copy the sheet(s)to a new workbook
If S > 0 Then
'*** INIZIO copia incolla valori
Application.Calculation = xlManual '--- cla: evita che ricalcolando dia errore nelle formule
Calculate
ThisWorkbook.ActiveSheet.Copy '---ORIGINALE
'**** inizio cla copia incolla valori aggiunta da Claudia
ActiveSheet.Cells.Select
Selection.Copy
ActiveCell.Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.PrintCommunication = False
ActiveSheet.PageSetup.PrintArea = "$e$13:$m$63" '***** delimita area stampa avviso <-----------------------------------
With ActiveSheet.PageSetup
.BlackAndWhite = False
.Zoom = 95
End With
Application.PrintCommunication = True
'*** FINE copia incolla valori
Set wb = ActiveWorkbook
End If
'You enter only "workbook" in colomn B to mail the whole workbook
'Use SaveCopyAs to make a copy of the workbook
If S = -1 Then
'qui vorrei inserire la creazione di un unico file pdf con tutti gli avvisi che sopra genera singolarmente
FileExtStr = "." & LCase(Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
NewNomePdf = StringSheetNames
Fname2 = DefPath & "TempFile " & strDate & FileExtStr
ThisWorkbook.SaveCopyAs Fname2
ActiveSheet.Activate
Set wb = Workbooks.Open(Fname2)
Application.DisplayAlerts = False
wb.Sheets(ActiveSheet.Name).Delete
Application.DisplayAlerts = True
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
End If
'
'Now we Publish to PDF
If S <> 0 Then
Fname = DefPath & Trim(ActiveSheet.Cells(8, "L").Value) & ".pdf" '57. AC
'------STOP NOME!!!!!
On Error Resume Next
wb.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'True 'OpenAfterPublish:=False '***********Salva PDF
On Error GoTo 0
wb.Close False
Set wb = Nothing
End If
On Error Resume Next
'
If S = -1 Then Kill Fname2
' Kill Fname '@@@@@@@@@@@@@@@@@@@@@@@ Se Commentato NON CANCELLa il file .pdf della Nota
On Error GoTo 0
End If
Next myCell
'
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Fatto! - file pdf generati nella directory " & DefPath, 0 + 48, " Avviso di Claudia :)"
End Sub
ho una macro che analizza il valore della colonna d (da d13 a d6xx): se ha il valore yes, fa una serie di operazioni aggiorna il foglio e poi lo esporta in pdf.
Di conseguenza ho n pdf in base a quanti yes ci sono.
Ora avrei bisogno che la macro possa generare anche un unico pdf.
Avevo pensato di sfruttare l'opzione "workbook" ossia se nell'ultima cella scrivo workbook lei (la macro) mi genera anche il pdf globale.
Avevo pensato di fare un copia valori del foglio aggiornato, ma mi sono persa.
Potete aiutarmi?
Grazie mille
Vi copio la macro attuale, che funziona.
Claudia
Sub CreazionePDFnew_V2() 'Funziona ma non c'è la creazione di un unico pdf per la stampa
Dim ShArr() As String, FArr() As String, strDate As String
Dim myCell As Range, cell As Range, rng As Range, Fname As String, Fname2 As String
Dim wb As Workbook, sh As Worksheet
Dim wbINuso As Workbook
Dim DefPath As String
Dim FileExtStr As String
'
Dim StringFileNames As String
Dim StringSheetNames As String
Dim FileNamesArray As Variant
Dim SheetNamesArray As Variant
Dim I As Long, S As Long, F As Long
Dim WrongData As Boolean
'
'Set folder where we save the temporary files
DefPath = [N1] '"A:\Scansioni\" '*
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
' -------- Da DECOMMENTARE
With Application
' .ScreenUpdating = False
' .EnableEvents = False
End With
Set wbINuso = ActiveWorkbook
nCelle = Cells(Rows.Count, "d").End(xlUp).Row
Set rng = Range("d13:" & "d" & nCelle) 'automatizzato con il range variabile
For Each myCell In rng
If LCase(myCell.Value) = "yes" Then
S = 0: F = 0
Erase ShArr: Erase FArr
'Set Error Boolean to False
WrongData = False
'
Range("C9").Value = ActiveSheet.Cells(myCell.Row, "c")
Range("B1").Value = ActiveSheet.Cells(myCell.Row, "a")
Range("c1").Value = ActiveSheet.Cells(myCell.Row, "b")
' Calculate
'Check if there are Sheet names in column B
'If B is empty S = 0 so you not want to send a sheet or sheets as pdf
If Trim(ActiveSheet.Cells(myCell.Row, "d").Value) = "" Then S = 0
'If there are sheet names in the B column S is the number of sheets it add to the Array
If LCase(Trim(ActiveSheet.Cells(myCell.Row, "d").Value)) <> "workbook" Then 'era B
StringSheetNames = ActiveSheet.Cells(8, "L").Value 'era q
SheetNamesArray = Split(StringSheetNames, Chr(10), -1)
If SheetNamesArray(I) <> "" Then
S = S + 1
ReDim Preserve ShArr(1 To S)
ShArr(S) = SheetNamesArray(I)
End If
On Error GoTo 0
Else
'If you only enter "workbook" in colomn B to mail the whole workbook S = -1
S = -1
End If
'Create PDF
'Create Date/time string for the file name
strDate = Format(Now, "yyyy.mm") 'Originale: strDate = Format(Now, "dd-mmm-yyyy hh-mm-ss")
'
'Copy the sheet(s)to a new workbook
If S > 0 Then
'*** INIZIO copia incolla valori
Application.Calculation = xlManual '--- cla: evita che ricalcolando dia errore nelle formule
Calculate
ThisWorkbook.ActiveSheet.Copy '---ORIGINALE
'**** inizio cla copia incolla valori aggiunta da Claudia
ActiveSheet.Cells.Select
Selection.Copy
ActiveCell.Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.PrintCommunication = False
ActiveSheet.PageSetup.PrintArea = "$e$13:$m$63" '***** delimita area stampa avviso <-----------------------------------
With ActiveSheet.PageSetup
.BlackAndWhite = False
.Zoom = 95
End With
Application.PrintCommunication = True
'*** FINE copia incolla valori
Set wb = ActiveWorkbook
End If
'You enter only "workbook" in colomn B to mail the whole workbook
'Use SaveCopyAs to make a copy of the workbook
If S = -1 Then
'qui vorrei inserire la creazione di un unico file pdf con tutti gli avvisi che sopra genera singolarmente
FileExtStr = "." & LCase(Right(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, ".", , 1)))
NewNomePdf = StringSheetNames
Fname2 = DefPath & "TempFile " & strDate & FileExtStr
ThisWorkbook.SaveCopyAs Fname2
ActiveSheet.Activate
Set wb = Workbooks.Open(Fname2)
Application.DisplayAlerts = False
wb.Sheets(ActiveSheet.Name).Delete
Application.DisplayAlerts = True
If wb.Sheets(1).Visible = xlSheetVisible Then wb.Sheets(1).Select
End If
'
'Now we Publish to PDF
If S <> 0 Then
Fname = DefPath & Trim(ActiveSheet.Cells(8, "L").Value) & ".pdf" '57. AC
'------STOP NOME!!!!!
On Error Resume Next
wb.ExportAsFixedFormat _
Type:=xlTypePDF, _
FileName:=Fname, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False 'True 'OpenAfterPublish:=False '***********Salva PDF
On Error GoTo 0
wb.Close False
Set wb = Nothing
End If
On Error Resume Next
'
If S = -1 Then Kill Fname2
' Kill Fname '@@@@@@@@@@@@@@@@@@@@@@@ Se Commentato NON CANCELLa il file .pdf della Nota
On Error GoTo 0
End If
Next myCell
'
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Fatto! - file pdf generati nella directory " & DefPath, 0 + 48, " Avviso di Claudia :)"
End Sub