Fix vba excel macro

Hello,
i have this macro

Sub GenerateProductLabelTranslate()

Dim destinationPathbongiovanni As String
Dim cellFormula As String
Dim chtObj As ChartObject

destinationPathbongiovanni = GetFolder("Dove salvo etichette TRADOTTE")

If destinationPathbongiovanni = "" Then Exit Sub

For i = 2 To Sheets("Farine").Range("A10000").End(xlUp).Row


If UCase(Sheets("Farine").Cells(i, 34)) = UCase("bongiovanni") Then

'save location
fname = destinationPathbongiovanni & "\" & Sheets("Farine").Cells(i, 33) & ".jpg"

' label id (where foreach working in template
Sheets("TemplateMicro").Cells(5, 19) = Sheets("Farine").Cells(i, 1)


'move to Template farine sheet
Sheets("TemplateMicro").Activate

'set zoom
Windows(1).Zoom = 100

cellFormula = Cells(5, 24).Formula
boldAlergensInIngredientsbong


Sheets("TemplateMicro").Range("A1:p14").Select
Selection.CopyPicture xlScreen, xlBitmap
w = Selection.Width
h = Selection.Height

With ThisWorkbook.ActiveSheet

.Activate

Set chtObj = .ChartObjects.Add(100, 30, 400, 250)
chtObj.Name = "TemporaryPictureChart"

'resize obj to picture size
chtObj.Width = w
chtObj.Height = h

ActiveSheet.ChartObjects("TemporaryPictureChart").Activate
ActiveChart.ChartArea.Border.LineStyle = xlNone
ActiveChart.Paste

ActiveChart.Export Filename:=Replace(fname, "/", " "), FilterName:="jpg"

chtObj.Delete

End With

Cells(5, 24).NumberFormat = "General"
If Cells(5, 24).HasFormula = False Then Cells(5, 24).Formula = cellFormula

' set zoom to 40%
'Windows(1).Zoom = 40
End If

Next i

Sheets("INSTRUCTIONS").Activate
MsgBox "Done!", vbInformation

End Sub

------------------------------------------

But the result is a bad image, i need a new one with and better resolution.

In attachment the image