• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Modification in Macro to copy same values to another sheet while generating PDF

naveeddil

New Member
Dear All,
I have to randomly select six clusters/ villages using the 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 the 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 a 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. It's hard to generate it manually as it is done for hundreds of surveys. Secondly, the probability sample is changing each time as its uses randbetween function.




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).

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

Code Module 2
Code:
'
' 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
 

Attachments

p45cal

Well-Known Member
1. Will there be more than one line of information added to the SUMMARY sheet for each pdf generated?
2. There are 9 headers in the SUMMARY sheet; where will each get its data from (be very specific)?
 

naveeddil

New Member
1. Yes, As i mentioned that there are 6 villages in each cluster so 6 rows from each clusters to be copied into Summary sheet.
2. Nine Headers:
First columns will get data from Template cell P3 and
Next 2 columns will get data from Template A10:B25000
Next 6 columns will get data from Template J10:O25000

Please run it once so you'll get the info of each PDF. Thank You
 

p45cal

Well-Known Member
In the attached, in Module2, I've added a sub AddToSummarySheet at the bottom. I've also added 2 lines to GenerateAllPDF (find by searching for the comment "added" at the end of those lines).
Notes:
check the 4280 is OK in the line:
Set rngtocopy = Intersect(.Range("A:A"), .Rows("10:4280")).SpecialCells(xlCellTypeVisible)
If you make it bigger, there'll be lots more visible rows - there is a more sophisticated way to get the right range to grab visible rows from.
The code uses column A of the SUMMARY sheet to determine which row to start adding new data to. This will fail if there are ever blank values in column A (at the bottom) but there is valid information you want to keep on other columns of that row.

ps.
there are 6 villages in each cluster
I note when I run this out-of-the-box the first cluster only has 5 entries. Is this correct?
 

Attachments

Last edited:

naveeddil

New Member
Yes, This worked perfectly. I will change the range as the original data is more than 40000.
After each generation, I have to clear summary sheets so hopefully, there will be no issue of the blank rows.
I am checking it and will let you know in case any issue notices.


Thank You very much :)
 

naveeddil

New Member
One more Request:

On the Welcome page Can I get a button that copies the randomly generated villages to the summary sheet without generating the PDF files!
 

naveeddil

New Member
Dear Geeks,

I don't know forum rules whether I should start a new thread or not as I need some coding help in the same file but the topic is change. I don't know forum rules regarding this.


I want to add 2 more Buttons on Welcome Screen to send the same data via Outlook default account to the individuals whose email addresses will be mentioned in Sheet3 in column K.


Button 1: Generate PDF and send attachment via Email

Button 2: Generate Summary and send as text/ table via Email
 

naveeddil

New Member
For
Dear Geeks,

I don't know forum rules whether I should start a new thread or not as I need some coding help in the same file but the topic is change. I don't know forum rules regarding this.


I want to add 2 more Buttons on Welcome Screen to send the same data via Outlook default account to the individuals whose email addresses will be mentioned in Sheet3 in column K.


Button 1: Generate PDF and send attachment via Email

Button 2: Generate Summary and send as text/ table via Email

For Individual cluster, I've wrote below MAcro and it perfectly worked :)


Code:
Sub EmailSINGLEclusterAspdf()

Dim EApp As Object
Set EApp = CreateObject("Outlook.Application")

Dim EItem As Object
Dim Path As String

Path = ActiveWorkbook.Path
Path = Path & "\" & "SINGLE_" & Range("S1").Value & ".pdf"

Sheet1.ExportAsFixedFormat Type:=xlTypePDF, filename:=Path, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    Set EItem = EApp.CreateItem(0)
         
    With EItem
        .To = Range("M8")
        .Subject = "LQAS clusters in District " & Range("B4")
        .Body = "Dear " & Range("B8") & "!" & vbNewLine & _
        "Please find attached PDF with village wise details of your assigned LQAS cluster " & Range("B6") & " in district " & Range("B4") & "." & vbNewLine & _
        vbNewLine & _
        "Kind Regards" & vbNewLine & _
        "TEAM"
       
        .Attachments.Add (Path)
   
        .Display
       
    End With
Exit Sub



End Sub
 
Top