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 Module 2
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 SubCode 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
