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]

Try This... Will save to desktop automatically...

Sub SaveAsJPG()
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
     Dim Fold As String
    Dim Name As String
    Dim Path As String
    
   
        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




    
    Fold = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Name = ActiveSheet.Range("G3").Value & " " & ActiveSheet.Range("C3").Value
    Path = Fold & Application.PathSeparator & Name & ".jpg"




    With ActiveSheet
        Set CopyRange = Range("A1:H43")
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            ExportName = Path
            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

 

[Shinod]

Thank you so much @Jimmypop. It is working. But it was a part of VBA. Could you suggest your edit here in the full VBA.

The error message is "Duplicate declaration in current scope"

Sub PrintPaySlips()
    Dim rCl As Range
    Dim rRng As Range
    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
        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

    
    Dim ChO As ChartObject, ExportName As String
    Dim CopyRange As Range
    Dim Pic As Picture
    Dim i As Long
     Dim Fold As String
    Dim Name As String
    Dim Path As String
    
   
        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




    
    Fold = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    Name = ActiveSheet.Range("G3").Value & " " & ActiveSheet.Range("C3").Value
    Path = Fold & Application.PathSeparator & Name & ".jpg"




    With ActiveSheet
        Set CopyRange = Range("A1:H43")
        If Not CopyRange Is Nothing Then
            Application.ScreenUpdating = False
            ExportName = Path
            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]

Will have a look when back at my pc tomorrow...

 

[Jimmypop]

In the meanwhile I think I see your problem...

On line

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

Remove

Dim xRg As Range

Seeing as this has already been declared previously in code...

 

[Shinod]

Now the error message is "Expected end with"

 

[Shinod]

In reality, this macro creates payslips in picture format. It is now functional. nonetheless, after producing a few payslips, certain inaccuracies appeared.

Will, you be kind enough to fix the issues.?

The macro is aasigned here in the (Create all Payslips)

Master Sheet June 2022 Test 6.xlsm

Shared with Dropbox

www.dropbox.com

 

[Jimmypop]

Hi Shinod

I am quite busy and would not be bale to get to everything. Where and on what line are you getting the Expected End With error message?

 

[Shinod]

It is not working to create all the payslips. Only a few are created by this.

 

[Jimmypop]

Will check as soon as available again. In the mean time if someone else wants to take a stab at this they more than welcome...