Need edit on this VBA

[Shinod]

I'm using this VBA to export a specific range to an Image file. But is asking where to save the file. Can someone help me to correct this VBA by setting a default file location?

And also don't know why this part is using "Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)".

Thanks in advance.

Sub SaveAsJPG()
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
   
        Dim xRg As Range
    Application.ScreenUpdating = False
        For Each xRg In Range("G12:G33")
            If xRg.Value = "0" Then
                xRg.EntireRow.Hidden = True
       
            Else
                xRg.EntireRow.Hidden = False
            End If
        Next xRg
    Application.ScreenUpdating = True


    With ActiveSheet
        Set CopyRange = Range("A1:H43")
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            ExportName = Application.GetSaveAsFilename(InitialFileName:=.Range("G3") & " " & .Range("C3"), fileFilter:="JPEG Files (*.jpg), *.jpg")
            If Not ExportName = "False" Then
                CopyRange.Copy
                .Pictures.Paste
                Set Pic = .Pictures(.Pictures.Count)
                Set ChO = .ChartObjects.Add(Left:=10, Top:=10, Width:=Pic.Width, Height:=Pic.Height)
                Application.CutCopyMode = False
                Do
                    DoEvents
                    Pic.Copy
                    DoEvents
                    ChO.Chart.Paste
                    DoEvents
                    i = i + 1
                Loop Until (ChO.Chart.Shapes.Count > 0 Or i > 50)

                ChO.Chart.Export Filename:=ExportName, Filtername:="JPG"
                ChO.Delete
                Pic.Delete
            End If
            Application.ScreenUpdating = True
        End If
    End With
End Sub

 

[Jimmypop]

Hi Shinod

I do not seem to find out why the payslips are not all generating, somewhere it gets to much for Excel to Copy / Paste and export 100+ pictures on one sheet in one go. I have modified the code a little, so it exports all as a .pdf and it did all payslips on my side. There is also a last little bit of code I added so after code runs it resets to the first data validation entry.

Try the following:

In your Module 5, delete the code and replace with:

Sub range_to_pdf_1()
    ActiveSheet.Range("B2:G42").ExportAsFixedFormat Type:=0, _
    Filename:=" Z:\ACCOUNTS\Shinod\Shinod Workings\Payslip Test\New\" & ActiveSheet.Range("G3").Value & _
    " " & ActiveSheet.Range("C3").Value, _
    Quality:=0, IncludeDocProperties:=False, IgnorePrintAreas:=False, _
    openafterpublish:=False
End Sub

Then in your Module9, delete the code and replace it with:

' print payslip for all selected employees
' uses the selected rows
Sub PrintPaySlips()
    Application.ScreenUpdating = False
    On Error GoTo errorhandler
    Dim rCl As Range
    Dim rRng As Range
    Dim xRg As Range
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
    Dim dv As Validation
    Dim vaSplit As Variant
    Dim Fold As String
    Fold = ("Z:\ACCOUNTS\Shinod\Shinod Workings\Payslip Test\New")
    With Sheets("Master Sheet")
        Set rRng = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
        For Each rCl In rRng
            With Sheets("Payslips")
                .Cells(3, 7).Value = rCl.Value
                For Each xRg In Range("G12:G33")
                    If xRg.Value = "0" Then
                        xRg.EntireRow.Hidden = True
                    Else
                        xRg.EntireRow.Hidden = False
                    End If
                    Next xRg
                    For Each xRg In Range("G12:G33")
                        If xRg.Value = "0" Then
                            xRg.EntireRow.Hidden = True
                        Else
                            xRg.EntireRow.Hidden = False
                        End If
                        Next xRg
                        With ActiveSheet
                            Set CopyRange = Range("A1:H43")
                            If Not CopyRange Is Nothing Then
                                ExportName = Path
                                If Not ExportName = "False" Then
                                    Call range_to_pdf_1
                                End If
                            End If
                        End With
                    End With
                    Next rCl
                End With
errorhandler:
                Resume Next
                MsgBox "All payslips have been exported successfully to " & Fold
                Application.ScreenUpdating = True
''''The code below will reset to the first data validation entry on Sheet "Master Sheet"
Range("G3").Activate
ActiveCell.Value = Worksheets("Master Sheet").Range("A1").Value
Set dv = ActiveCell.Validation
vaSplit = Range(dv.Formula1).Value
For i = LBound(vaSplit, 1) To UBound(vaSplit, 1)
    If vaSplit(i, 1) = ActiveCell.Value Then
        If i < UBound(vaSplit, 1) Then
            ActiveCell.Value = vaSplit(i + 1, 1)
            Exit For
        End If
    End If
    Next i
End Sub

Now try the orange “Create all payslips” button…