Short and Smart vba code for a report generating.

[mrxdm]

[FONT=Courier New, Courier, monospace, arial, sans-serif]I need your kind help in the following code for preparing a treatment history reports of patients that how can I short and smart it? or any more suggestions form you in this matter.

Private Sub ComboBox1_Enter()   [/COLOR][/FONT][COLOR=#ff0000][FONT=Courier New, Courier, monospace, arial, sans-serif]'**** It takes the names of all patients from Sheet2 where from '****we can select a name to generate his / her medical history report.[/FONT][/COLOR][FONT=Courier New, Courier, monospace, arial, sans-serif][COLOR=#000000]
Dim i As Double
Dim final As Double
Dim tareas As String

ComboBox1.BackColor = &H80000005

For i = 1 To ComboBox1.ListCount

               ComboBox1.RemoveItem 0

           Next i

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

For i = 11 To final
tareas = Sheet2.Cells(i, 2)
PUF5r.ComboBox1.AddItem (tareas)
Next
End Sub
Private Sub ComboBox1_Click()
Dim i As Long
Dim final As Integer

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 ComboBox1 = Sheet2.Cells(i, 2) Then    'according to patient's name it shows more details
PUF5r.Label1.Caption = Sheet2.Cells(i, 1) 'PtR No
PUF5r.Label3.Caption = Sheet2.Cells(i, 3) 's/o d/o w/o
PUF5r.Label2.Caption = Sheet2.Cells(i, 4) 'Relative Name

Exit For
End If
Next

End Sub


Private Sub CommandButton1_Click()  '**** Once the name selected from combobox1 than press CommandButton1 to generate the report.
Dim i As Double 'Long
Dim final As Integer

Me.Hide
Application.ScreenUpdating = False
Worksheets("Rpt").Visible = True
Worksheets("Rpt").Unprotect "xyz" '**** password

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("$L$9") = "=TODAY()"                    'Name of Sheet5 is Rpt
Sheet5.Range("$L$4") = Sheet2.Cells(i, 1) 'PtR No (Patient's registration no)
Sheet5.Range("$D$13") = Sheet2.Cells(i, 2) 'Patient's Name
Sheet5.Range("$C$14") = Sheet2.Cells(i, 3) 's/o d/o w/o
Sheet5.Range("$D$14") = Sheet2.Cells(i, 4) 'Relative's Name
Sheet5.Range("$D$15") = Sheet2.Cells(i, 5) 'Phone
Sheet5.Range("$L$14") = Sheet2.Cells(i, 6) 'Registration Date
Sheet5.Range("$D$16") = Sheet2.Cells(i, 9) 'Symptoms
Sheet5.Range("$H$15") = Sheet2.Cells(i, 10) 'Tehreak
Sheet5.Range("$M$16") = Sheet2.Cells(i, 14) 'T. visits of this Patient
Sheet5.Range("$K$19") = Sheet2.Cells(i, 10) 'PIN (Tehreak, Pulse indication No)

[/COLOR][/FONT][FONT=Courier New, Courier, monospace, arial, sans-serif][COLOR=#ff0000]'**** I need help here that how I can short this piece of code bellow which generates proper report in worksheet "Rpt"
'**** I want here to copy in sheet "Rpt" (wsheet5) : first treatment given as " treatment date, Treatment given, no of days for medicine is given, food plan " from wsheet2
'**** then if more treatments are given then it should be continued copy in the worksheet "Rpt" after last used row or if there is no more.
'**** treatment given to the patient then do nothing more.[/COLOR][/FONT][FONT=Courier New, Courier, monospace, arial, sans-serif][COLOR=#000000]

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

	'**** above code is for a single page setting of report, what I do if the report exceeds from one page (exceeds then 14 time treatments), how I shift more remaing treatment data to next sheet (add new sheet to enter remaining data with same worksheet format of "Rpt".



Sheet5.Range("$M$49") = Sheet2.Cells(i, 15) 'T Bills amount  '**** it should be copied at bottom of the report.
Sheet5.Range("$M$50") = Sheet2.Cells(i, 16) 'Rcvd
Sheet5.Range("$M$51") = Sheet2.Cells(i, 17) 'Bal
Sheet5.Range("$C$50") = Sheet2.Cells(i, 18) 'Pt Status
Exit For
End If
Next
Worksheets("Rpt").Protect "xyz", DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("Rpt").EnableSelection = xlNoSelection

		
			'**** now convert worksheet Rpt to PDF file name is from cell value $D$13 and opens it in PDF

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  '**** it shows for more reports to print.

End Sub[/COLOR][/FONT]

 

[RanOtherwise]

It looks like after row 19 in Sheet5, everything gets coppied skipping 1 row and every 4 to get the data. Maybe try (beginning

Dim j As Long, k As Long


for j = 21 to 45 step 2
  k = (j - 21) / 2


  With Sheet5
    .Range("C" & j).Value = Sheet2.Cells(i, 19 + k).Value
	.Range("D" & j).Value = Sheet2.Cells(i, 20 + k).Value
	.Range("L" & j).Value = Sheet2.Cells(i, 21 + k).Value
	.Range("M" & j).Value = Sheet2.Cells(i, 22 + k).Value
  End With
Next j

 

[offthelip]

You can speed up your code by a factor of a 1000 or so by using variant arrays; I have needed to post this so many times on this forum that I keep this paragraph ready to go:
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.
So instead of writing a loop which loops down a range copying one row at a time which will take along time if you have got 50000 rows it is much quicker to load the 50000 lines into a variant array ( one worksheet access), then copy the lines to a variant array and then write the array back to the worksheet, ( one worksheet access for each search that you are doing),
I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
So to speed up your code you can load all of sheet 2 into a variant array and then address in exactly the same way you are currently addressing sheet2
To load the array

With Worksheets("sheet2")
lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(.Cells(1, 1), .Cells(lastrow, 70))
End With

then to address the array
from Ranotherwise suggestions
change:

[COLOR=#333333].Range("D" & j).Value = Sheet2.Cells(i, 20 + k).Value[/COLOR]

to

[COLOR=#333333].Range("D" & j).Value = inarr(i, 20 + k)[/COLOR]

You could also speed the code up by using a variant array to copy everything into and then write the variant array back sheet5. However this would mean changing all your addresses which currently uses column letters which obviously won't work with a variant array

 

[RanOtherwise]

Well said, offthelip! That is definitely the next level of performance improvement.

Mind if I steal that paragraph Maybe it should be pinned somewhere.

 

[offthelip]

certainly it will save me needing to cut and paste it all the time just put a link in

 

[mrxdm]

offthelip , It is an excellent advice, I shall use it in my code to get the best and quick results and if got any problem then I ask you again.

[FONT=&quot]I thank you for your part in my journey.[/FONT]

 

[mrxdm]

I did it as per your suggestions but there is some problem in the code that it is executing but giving no result (not generating a report).
Please see the code:

Private Sub CommandButton1_Click()
Dim i As Double 'Long
Dim final As Integer
Dim j As Long, k As Long
Dim LastCol As Integer


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)


'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
        '''at here code works.....but no result of below part
        
        With Worksheets("PtR") 'sheet2
        LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'I changed it for the last col
        'lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
        inarr = Range(.Cells(1, 1), .Cells(LastCol, 100))
        End With


    For j = 19 To 45 Step 2
    k = (j - 19) / 2
If PUF5r.ComboBox1 = Sheet2.Cells(i, 2) Then
  With Sheet5
            .Range("C" & j).Value = inarr(i, 19 + k) 'showing " run time error 9"
            .Range("D" & j).Value = inarr(i, 21 + k)
            .Range("K" & j).Value = inarr(i, 20 + k)
            .Range("L" & j).Value = inarr(i, 22 + k)
            '.Range("M" & j).Value = inarr(i, 22 + k)
  End With
'Next j
Exit For
End If


Next


Worksheets("Rpt").EnableSelection = xlNoSelection


Worksheets("Rpt").ExportAsFixedFormat Type:=xlTypePDF, Filename:=ThisWorkbook.Path & "\ Tib_e_SabirX" & " 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 ""TibSabirX"" folder:"
'PUF5rI.Show
End Sub

Please see the images of my worksheet2(PtR) and sheet5(Rpt) to better understand it.
https://photos.app.goo.gl/Xz1xGOgRgkKjV1912

 

[offthelip]

With Worksheets("PtR") 'sheet2 LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column 'I changed it for the last col
'lastrow = .Cells(Rows.Count, "A").End(xlUp).Row
inarr = Range(.Cells(1, 1), .Cells(LastCol, 100))
End With

The addressing mode I was using has the rows and columns the opposite way round ,I think my original code was correct
inarr=Range(.cells( row 1, column1), . cells(row lastrow number, column 70))
when using numbers in Cells () functions it is cells( Row, Column)
This may be the cause of the problem. I used 70 as the last column because none of your code used values gerater than 70 so that should be sufficient

To debug the problem further put a breakpoiint at the start of the for j = 19 to 45 step 2 loop and checkon the local page that the varaint array inarr is showing the correct values.
The run time error 9 is subscript out of range which is very likely to be caused by the array inarr being wrong. ( because you modifed my code )
Try it with my code for loading the inarr array.

 

[mrxdm]

Ok, I shall do it as per your guidelines.

 

[mumps]

I'm not sure how much it would help, but you can try adding the following lines of code at the beginning and end of your macro:

Application.ScreenUpdating = False
Application.Calculate = xlCalculationManual
'your code goes here
Application.ScreenUpdating = True
Application.Calculate = xlCalculationAutomatic