VBA Generating PDFs with separate excel sheet as well

[naveeddil]

Dear All,
I have to randomly select six clusters/ villages using PPS method (Probability proportional to size) for a geographic unit for surveys. I already have an excel file that does it for me using macro (Module1: RUN_CLUSTER) and generates PDF files using the macro (Module2)

I have a fixed DATA sheet with villages. I add geographic unit codes and Surveyor Name/ Code on the LIST sheet.

The Macro does all the required steps via already placed formulas in Template sheet. All I have to do is click on Generate All PDFs on the Welcome sheet, give the folder's location, and all PDFs are saved one by one.

Now I need modification in the macro that as soon it generates and print data for each cluster in PDF file so it should also add the same village names to another sheet called SUMMARY (Added at the end with sample data) so I could have same data in excel. Its hard to generate it manually as it is done for hundreds of surveys. Secondly the probablity sample is changing each time as its using randbetween function.

The unlocked sheet attach for your kind review: Excel XLSM File


PPS method (Probability proportional to size (PPS) sampling is a method of sampling from a finite population in which a size measure is available for each population unit before sampling and where the probability of selecting a unit is proportional to its size).

 

[naveeddil]

Module 1 Code:

'
' RUN CLUSTER CALCULATION
'
' Keyboard Shortcut: Ctrl+Shift+R
'
Sub RUN_CLUSTER()
    Application.Calculation = xlManual
    Application.CalculateBeforeSave = True
    Sheet1.Application.Calculate
    'ActiveSheet.Protect Password:="Ashraf@75", userInterfaceOnly:=True
    Sheet1.Range("$A$9:$O$15010").AutoFilter Field:=10, Criteria1:=RGB(255 _
        , 255, 0), Operator:=xlFilterCellColor
End Sub

Module 2 consists of multiple:

'
' Macro1 Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'
Sub Macro1()
    Dim Path As String
    
    Path = ActiveWorkbook.Path
    Path = Path & "\" & "_Selection.pdf"
    
    Sheet1.ExportAsFixedFormat Type:=xlTypePDF, FileName:= _
        Path _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
        :=False, OpenAfterPublish:=True
End Sub

'
' SavePdfQuietly - Export the template as PDF without opening it
'
Sub SavePdfQuietly(OutputPath As String)
    Const cUICellFilename As String = "S1"
    Const cUICellUcCode As String = "P3"
    Dim UcCode As String
    Dim FileName As String
    Dim FullPath As String
    
    On Error GoTo Retry_SavePdfQuietly
    
    FileName = Sheet1.Range(cUICellFilename).Value
    FileName = SanitizeFileName(FileName)
    FullPath = OutputPath & "\" & FileName & ".pdf"

    Sheet1.ExportAsFixedFormat Type:=xlTypePDF _
        , FileName:=FullPath _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True _
        , IgnorePrintAreas:=False, OpenAfterPublish:=False
                
Exit_SavePdfQuietly:
    Exit Sub
Err_SavePdfQuietly:
    UcCode = Sheet1.Range(cUICellUcCode).Value
    MsgBox "PDF Export Error for UC " & UcCode, vbExclamation, Err.Number
    Resume Exit_SavePdfQuietly
Retry_SavePdfQuietly:
    On Error GoTo Err_SavePdfQuietly
    FileName = Sheet1.Range(cUICellUcCode).Value
    FileName = SanitizeFileName(FileName)
    FullPath = OutputPath & "\" & FileName & ".pdf"

    Sheet1.ExportAsFixedFormat Type:=xlTypePDF _
        , FileName:=FullPath _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True _
        , IgnorePrintAreas:=False, OpenAfterPublish:=False
    Resume Exit_SavePdfQuietly
End Sub

'
' Prompt for path and generate PDF for each UC on LIST
'
Sub GenerateAllPDF()
    Const cUICellMsg As String = "B20"
    Const cUICellUcCode As String = "P3"
    Const cUICellCampaign As String = "E8"
    Dim NextUcCode As String
    Dim OutputFolder As String
    Dim LastUcRow As Long
    Dim i As Long
    
    On Error GoTo Err_GenerateAllPDF
    
    LastUcRow = Sheet3.Range("G" & Rows.Count).End(xlUp).Row
    
    ' Open the file dialog
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
    
        OutputFolder = .SelectedItems(1)
        ChDir OutputFolder
        
        For i = 2 To LastUcRow
    
            ' Pick next UC
            NextUcCode = Sheet3.Range("G" & i).Value
        
            ' Set UC to template
            Sheet1.Range(cUICellUcCode).Value = NextUcCode
            Sheet3.Range("B" & i).Value = Sheet4.Range(cUICellCampaign).Value
        
            ' Generate PDF
            Call RUN_CLUSTER
            Call DisplayMessage(cUICellMsg, "In progress: " & (i - 1) & "/" & (LastUcRow - 1))
            Call SavePdfQuietly(OutputFolder)
        
        Next i
    End With
    
    Call DisplayMessage(cUICellMsg, "")
    Application.ScreenUpdating = True
    
Exit_GenerateAllPDF:
    Exit Sub
Err_GenerateAllPDF:
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_GenerateAllPDF
End Sub

Sub DisplayMessage(cell As String, sMsg As String)
    Application.ScreenUpdating = True
    Range(cell).FormulaR1C1 = sMsg
    Application.ScreenUpdating = False
End Sub

'
' Remove illegal characters from filename
'
Public Function SanitizeFileName(FileNameIn As String) As String
    Dim i As Integer
    Dim ValidFileName As String
    
    Const IllegalChars = "\/|?*<>"":"
    ValidFileName = FileNameIn
    For i = 1 To Len(IllegalChars)
        ValidFileName = Replace(ValidFileName, Mid(IllegalChars, i, 1), "_")
    Next i
    SanitizeFileName = ValidFileName
End Function

 

[naveeddil]

Can someone please look into this code?

 

[Fluff]

Cross-posting (posting the same question in more than one forum) is not against our rules, but the method of doing so is covered by #13 of the Forum Rules.

Be sure to follow & read the link at the end of the rule too!

Cross posted at: Modification in Macro to copy same values to another sheet while generating PDF
If you have posted the question at more places, please provide links to those as well.

If you do cross-post in the future and also provide links, then there shouldn’t be a problem.

 

[naveeddil]

Copied!
although there was no reply here so thats why I posted after more than 24 hours at the second platform

 

[Fluff]

That doesn't change the fact that you need to let us know.

 

[naveeddil]

I'll be careful in the future.
On a lighter note: instead of searching cross-posted threads; If one reply the member questions looking for answers so that would be more grateful and thankful

 

[naveeddil]

Got the solution

Sub addtoSummarysheet(Destn)    'added this sub
With Sheet1
  Set rngtocopy = Intersect(.Range("A:A"), .Rows("10:25000")).SpecialCells(xlCellTypeVisible)
  Destn.Resize(rngtocopy.Cells.Count) = .Range("P3").Value
End With
For Each are In rngtocopy.Areas
  Destn.Offset(, 1).Resize(are.Rows.Count, 2).Value = are.Resize(, 2).Value
  Destn.Offset(, 3).Resize(are.Rows.Count, 6).Value = are.Offset(, 9).Resize(, 6).Value
  Set Destn = Destn.Offset(are.Rows.Count)
Next are
End Sub

 

[Peter_SSs]

On a lighter note: instead of searching cross-posted threads; If one reply the member questions looking for answers so that would be more grateful and thankful

Another way to look at it: If you had spent half an hour (or more) answering the question (for no pay) and then found out that the question had already been answered on another forum, would that make you feel good, and look forward to helping that person again next time they asked a question?

 

[naveeddil]

Perfectly agreed!

but as we say A straw for the drowning; So if someone is having a hard time with something and nothing in response so will one have to look for other opportunities or wait for drowning.

And if I get two answers so I will Thank both volunteers who take out their precious time for me and even if that is not helpful; at least someone has tried and volunteered for me who needs to be appreciated wholeheartedly.