0
\$\begingroup\$

I am pasting here my working code which generate report in worksheet then save it in pdf format then open it in pdf after selecting a name from a combobox in userform then press commandbutton1 to execute it.

Source worksheet2 (RpT) Target worksheet5 (Ptr)

all do well but it is a long code which takes time to perform so any idea to reduce it in a smart way. Any expert brother can re-code it for me?

Private Sub CommandButton1_Click()
Dim i As Double 'Long
Dim final As Integer

Me.Hide
Application.ScreenUpdating = False
Worksheets("Rpt").Visible = True

On Error Resume Next

For i = 11 To 65000
If Sheet2.Cells(i, 2) = "" Then
final = i - 1
Exit For
End If
Next

For i = 11 To final
If PUF5r.ComboBox1 = Sheet2.Cells(i, 2) Then
Sheet5.Range("L9") = "=TODAY()"
Sheet5.Range("L4") = Sheet2.Cells(i, 1) 'PtR No
Sheet5.Range("D13") = Sheet2.Cells(i, 2) 'Pt Name
Sheet5.Range("C14") = Sheet2.Cells(i, 3) 's/o d/o w/o
Sheet5.Range("D14") = Sheet2.Cells(i, 4) 'Relative Name
Sheet5.Range("D15") = Sheet2.Cells(i, 5) 'Phone
Sheet5.Range("L14") = Sheet2.Cells(i, 6) 'Reg Date
Sheet5.Range("D16") = Sheet2.Cells(i, 9) 'Symptoms
Sheet5.Range("H15") = Sheet2.Cells(i, 10) 'Tehreak
Sheet5.Range("M16") = Sheet2.Cells(i, 14) 'T. visits
Sheet5.Range("$K$19") = Sheet2.Cells(i, 10) 'PIN (Tehreak, Pulse indication No)
'specialy following this piece of code shoud be reduce.
Sheet5.Range("$C$19") = Sheet2.Cells(i, 6) 'Trmnt dt1 
Sheet5.Range("$D$19") = Sheet2.Cells(i, 11) 'Trmnt1
Sheet5.Range("$L$19") = Sheet2.Cells(i, 12) 'For Days1
Sheet5.Range("$M$19") = Sheet2.Cells(i, 13) 'Food Plan1
Sheet5.Range("$C$21") = Sheet2.Cells(i, 19) 'Trmnt dt2
Sheet5.Range("$K$21") = Sheet2.Cells(i, 20) 'PIN2
Sheet5.Range("$D$21") = Sheet2.Cells(i, 21) 'Trmnt2
Sheet5.Range("$L$21") = Sheet2.Cells(i, 22) 'For Days2
'Sheet5.Range("$M$21") = Sheet2.Cells(i, 13) 'Food Plan2
Sheet5.Range("$C$23") = Sheet2.Cells(i, 23) 'Trmnt dt3
Sheet5.Range("$K$23") = Sheet2.Cells(i, 24) 'PIN3
Sheet5.Range("$D$23") = Sheet2.Cells(i, 25) 'Trmnt3
Sheet5.Range("$L$23") = Sheet2.Cells(i, 26) 'For Days3
Sheet5.Range("$C$25") = Sheet2.Cells(i, 27) 'Trmnt dt4
Sheet5.Range("$K$25") = Sheet2.Cells(i, 28) 'PIN4
Sheet5.Range("$D$25") = Sheet2.Cells(i, 29) 'Trmnt4
Sheet5.Range("$L$25") = Sheet2.Cells(i, 30) 'For Days4
Sheet5.Range("$C$27") = Sheet2.Cells(i, 31) 'Trmnt dt5
Sheet5.Range("$K$27") = Sheet2.Cells(i, 32) 'PIN5
Sheet5.Range("$D$27") = Sheet2.Cells(i, 33) 'Trmnt5
Sheet5.Range("$L$27") = Sheet2.Cells(i, 34) 'For Days5
Sheet5.Range("$C$29") = Sheet2.Cells(i, 35) 'Trmnt dt6
Sheet5.Range("$K$29") = Sheet2.Cells(i, 36) 'PIN6
Sheet5.Range("$D$29") = Sheet2.Cells(i, 37) 'Trmnt6
Sheet5.Range("$L$29") = Sheet2.Cells(i, 38) 'For Days6
Sheet5.Range("$C$31") = Sheet2.Cells(i, 39) 'Trmnt dt7
Sheet5.Range("$K$31") = Sheet2.Cells(i, 40) 'PIN7
Sheet5.Range("$D$31") = Sheet2.Cells(i, 41) 'Trmnt7
Sheet5.Range("$L$31") = Sheet2.Cells(i, 42) 'For Days7
Sheet5.Range("$C$33") = Sheet2.Cells(i, 43) 'Trmnt dt8
Sheet5.Range("$K$33") = Sheet2.Cells(i, 44) 'PIN8
Sheet5.Range("$D$33") = Sheet2.Cells(i, 45) 'Trmnt8
Sheet5.Range("$L$33") = Sheet2.Cells(i, 46) 'For Days8
Sheet5.Range("$C$35") = Sheet2.Cells(i, 47) 'Trmnt dt9
Sheet5.Range("$K$35") = Sheet2.Cells(i, 48) 'PIN9
Sheet5.Range("$D$35") = Sheet2.Cells(i, 49) 'Trmnt9
Sheet5.Range("$L$35") = Sheet2.Cells(i, 50) 'For Days9
Sheet5.Range("$C$37") = Sheet2.Cells(i, 51) 'Trmnt dt10
Sheet5.Range("$K$37") = Sheet2.Cells(i, 52) 'PIN10
Sheet5.Range("$D$37") = Sheet2.Cells(i, 53) 'Trmnt10
Sheet5.Range("$L$37") = Sheet2.Cells(i, 54) 'For Days10
Sheet5.Range("$C$39") = Sheet2.Cells(i, 55) 'Trmnt dt11
Sheet5.Range("$K$39") = Sheet2.Cells(i, 56) 'PIN11
Sheet5.Range("$D$39") = Sheet2.Cells(i, 57) 'Trmnt11
Sheet5.Range("$L$39") = Sheet2.Cells(i, 58) 'For Days11
Sheet5.Range("$C$41") = Sheet2.Cells(i, 59) 'Trmnt dt12
Sheet5.Range("$K$41") = Sheet2.Cells(i, 60) 'PIN12
Sheet5.Range("$D$41") = Sheet2.Cells(i, 61) 'Trmnt12
Sheet5.Range("$L$41") = Sheet2.Cells(i, 62) 'For Days12
Sheet5.Range("$C$43") = Sheet2.Cells(i, 63) 'Trmnt dt13
Sheet5.Range("$K$43") = Sheet2.Cells(i, 64) 'PIN13
Sheet5.Range("$D$43") = Sheet2.Cells(i, 65) 'Trmnt13
Sheet5.Range("$L$43") = Sheet2.Cells(i, 66) 'For Days13
Sheet5.Range("$C$45") = Sheet2.Cells(i, 67) 'Trmnt dt14
Sheet5.Range("$K$45") = Sheet2.Cells(i, 68) 'PIN14
Sheet5.Range("$D$45") = Sheet2.Cells(i, 69) 'Trmnt14
Sheet5.Range("$L$45") = Sheet2.Cells(i, 70) 'For Days14

Sheet5.Range("$L$49") = Sheet2.Cells(i, 15) 'T Bills amount
Sheet5.Range("$L$50") = Sheet2.Cells(i, 16) 'Rcvd
Sheet5.Range("$L$51") = Sheet2.Cells(i, 17) 'Bal
Sheet5.Range("$C$50") = Sheet2.Cells(i, 18) 'Pt Status
Exit For
End If
Next

Worksheets("Rpt").EnableSelection = xlNoSelection

Worksheets("Rpt").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\ Tib_e_Sabir" & " Report of " & Worksheets("Rpt").Range("$D$13").Value _
        , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=True
        'MsgBox "PDF file has been created and saved in ""TibSabir"" folder:"
PUF5rI.Show

'Unload Me

End Sub
Improve this question
\$\endgroup\$
4
  • 1
    \$\begingroup\$ Assuming, of course, that you don't have additional data stored beyond row 65000, lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, col).End(xlUp).row is a much more efficient way of identifying the last used row in a column. It also works well when you update to a newer version of Excel that supports >1 million rows of data. Also, lastRow is a more meaningful name than final. "final" what? \$\endgroup\$
    – FreeMan
    Apr 16, 2018 at 14:44
  • \$\begingroup\$ @FreeMan that is an answer. please post it as an answer... \$\endgroup\$
    – Vogel612
    Apr 19, 2018 at 16:48
  • \$\begingroup\$ Please do not link to medical data attached to personally identifiable information. For one it most likely is illegal under your jurisdiction and secondly it does not get you support for your implementation either. \$\endgroup\$
    – Vogel612
    Apr 22, 2018 at 14:25
  • \$\begingroup\$ Ok, Vogel612♦ and I understand it but I provided data in my workbook was not orignal all names were changed. Any way please you tell me now what should I do to resolve my problem of code? \$\endgroup\$
    – Tabib Riaz Hussain
    Apr 22, 2018 at 14:43

1 Answer 1

Reset to default
1
\$\begingroup\$

You are looping without the need to do so. If I've understood your example you can replace your loo For i = 11 to final ... Next with what follows below. Since you're looking at each row in column 2 to see if it matches what's in the combobox you can do that directly without looping.

Dim comboBoxMatch As Range
Set comboBoxMatch = Sheet2.Columns.Find(PUF5r.ComboBox1, LookAt:=xlWhole)

You've already a comment about reducing your code. If you ignore the first group that's populating on row 19 they all follow a pattern for the row and column population. I came up with the two functions below that return the same information. Using the generic name userNumber you supply it as an argument to the function in return you'll get the row and first column that are used for population.

Private Function GetRowFor(ByVal userNumber As Long) As Long
    If userNumber >= 2 Then
        GetRowFor = 19 + (userNumber - 1) * 2
    End If
End Function

Private Function GetFirstSourceColumnFor(ByVal userNumber As Long) As Long
    If userNumber >= 2 Then
        GetFirstSourceColumnFor = 15 + (userNumber - 1) * 4
    End If
End Function

You can now replace the population of users 2-14 with a single sub that takes in the userNumber and will populate the information.

Private Sub PopulateUserInformation(ByVal userNumber As Long, ByVal sourceSheet As Worksheet, ByVal sourceRow As Long, ByVal destinationSheet As Worksheet)
    If userNumber >= 2 Then
        Dim populationRow As Long
        populationRow = GetRowFor(userNumber)

        Dim firstSourceColumn As Long
        firstSourceColumn = GetFirstSourceColumnFor(userNumber)

        destinationSheet.Cells(populationRow, "C").Value2 = sourceSheet.Cells(sourceRow, firstSourceColumn).Value2
        destinationSheet.Cells(populationRow, "K").Value2 = sourceSheet.Cells(sourceRow, firstSourceColumn + 1).Value2
        destinationSheet.Cells(populationRow, "D").Value2 = sourceSheet.Cells(sourceRow, firstSourceColumn + 2).Value2
        destinationSheet.Cells(populationRow, "L").Value2 = sourceSheet.Cells(sourceRow, firstSourceColumn + 3).Value2
    End If
End Sub

From here it's about replacing lines of code with the updated sub procedure calls. The population of information now resides in its own sub, and its name describes what it's doing.

Private Sub PopulateInformation(ByVal sourceSheet As Worksheet, ByVal sourceRow As Long, ByVal destinationSheet As Worksheet)
    destinationSheet.Range("L9").Value2 = "=TODAY()"
    destinationSheet.Range("L4").Value2 = sourceSheet.Cells(i, 1).Value2 'PtR No
    destinationSheet.Range("D13").Value2 = sourceSheet.Cells(i, 2).Value2 'Pt Name
    destinationSheet.Range("C14").Value2 = sourceSheet.Cells(i, 3).Value2 's/o d/o w/o
    destinationSheet.Range("D14").Value2 = sourceSheet.Cells(i, 4).Value2 'Relative Name
    destinationSheet.Range("D15").Value2 = sourceSheet.Cells(i, 5).Value2 'Phone
    destinationSheet.Range("L14").Value2 = sourceSheet.Cells(i, 6).Value2 'Reg Date
    destinationSheet.Range("D16").Value2 = sourceSheet.Cells(i, 9).Value2 'Symptoms
    destinationSheet.Range("H15").Value2 = sourceSheet.Cells(i, 10).Value2 'Tehreak
    destinationSheet.Range("M16").Value2 = sourceSheet.Cells(i, 14).Value2 'T. visits
    destinationSheet.Range("$K$19").Value2 = sourceSheet.Cells(i, 10).Value2 'PIN (Tehreak, Pulse indication No)

    'The first one doesn't follow a pattern. As such it's handled separately
    'Consider having it also follow the same pattern
    destinationSheet.Range("$C$19").Value2 = sourceSheet.Cells(i, 6).Value2 'Trmnt dt1
    destinationSheet.Range("$D$19").Value2 = sourceSheet.Cells(i, 11).Value2 'Trmnt1
    destinationSheet.Range("$L$19").Value2 = sourceSheet.Cells(i, 12).Value2 'For Days1
    destinationSheet.Range("$M$19").Value2 = sourceSheet.Cells(i, 13).Value2 'Food Plan1

    'destinationsheet.Range("$M$21").value2 = sourcesheet.Cells(i, 13).value2 'Food Plan2
    PopulateUserInformation 2, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 3, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 4, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 5, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 6, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 7, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 8, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 9, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 10, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 11, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 12, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 13, sourceSheet, sourceRow, destinationSheet
    PopulateUserInformation 14, sourceSheet, sourceRow, destinationSheet

    destinationSheet.Range("$L$49").Value2 = sourceSheet.Cells(i, 15).Value2 'T Bills amount
    destinationSheet.Range("$L$50").Value2 = sourceSheet.Cells(i, 16).Value2 'Rcvd
    destinationSheet.Range("$L$51").Value2 = sourceSheet.Cells(i, 17).Value2 'Bal
    destinationSheet.Range("$C$50").Value2 = sourceSheet.Cells(i, 18).Value2 'Pt Status
End Sub

Your main macro now shows a higher level view without showing all the details. You can certainly move things around and add error handling. Please note that On Error Resume Next will plow through any errors that arise, and I've removed its use.

Private Sub CommandButton1_Click()
    Me.Hide
    Application.ScreenUpdating = False
    Worksheets("Rpt").Visible = True

    Dim comboBoxMatch As Range
    Set comboBoxMatch = Sheet2.Columns.Find(PUF5r.ComboBox1, LookAt:=xlWhole)
    If Not comboBoxMatch Is Nothing Then
        PopulateInformation Sheet2, comboBoxMatch.Row, sheet5
    End If

    Worksheets("Rpt").EnableSelection = xlNoSelection

    Dim fileSaveName As String
    fileSaveName = ThisWorkbook.Path & "\ Tib_e_Sabir" & " Report of " & Worksheets("Rpt").Range("$D$13").Value2
    Worksheets("Rpt").ExportAsFixedFormat Type:=xlTypePDF, Filename:=fileSaveName, _
                                                            Quality:=xlQualityStandard, _
                                                            IncludeDocProperties:=True, _
                                                            IgnorePrintAreas:=False, _
                                                            OpenAfterPublish:=True

    'MsgBox "PDF file has been created and saved in ""TibSabir"" folder:"
    PUF5rI.Show

    'Unload Me
End Sub
Improve this answer
\$\endgroup\$
2
  • \$\begingroup\$ Good work +1. I might For i = 2 to 14 PopulateUserInformation i, sourcesheet, sourcerow, destination sheet \$\endgroup\$
    – Raystafarian
    Apr 16, 2018 at 21:20
  • \$\begingroup\$ I had that initially, it just didn't feel right... Though with a bit of refactoring PopulateUserInformation could be self containing and not need to have the userNumber as an argument. \$\endgroup\$
    – IvenBach
    Apr 16, 2018 at 23:06

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge that you have read and understand our privacy policy and code of conduct.

Not the answer you're looking for? Browse other questions tagged or ask your own question.