Snasui Excel Forum

Code: Select all

Sub SavePDF()
'
'
Dim name1 As String
Dim fileName As String
Dim filepath As String

    Dim shs() As Variant                        
    Dim i As Integer, j As Integer            
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strpath = ActiveWorkbook.Path
filepath = strpath & "\"

name1 = Range("B4").Value & "_Jan_2019"

    For i = 2 To Sheets.Count              
        ReDim Preserve shs(j)               
        shs(j) = Worksheets(i).name      

fileName = Application.GetSaveAsFilename(filepath & name1 & name2 & name3, _
                                         FileFilter:="PDF Files (*.pdf), *.pdf", _
                                         Title:="Select Path and FileName to save")


    If fileName <> "False" Then

        With ActiveWorkbook

                .Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
                    fileName, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

        End With

    End If
                                
            j = j + 1    
    Next i               
                                
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Code: Select all

'Other code
    For i = 2 To Sheets.Count              
        ReDim Preserve shs(j)               
        shs(j) = Worksheets(i).name
        name1 = Worksheets(i).Range("B3").Value & "_Jan_2019"
'Other code

Code: Select all

Sub SavePDF()
'
'
Dim name1 As String
Dim fileName As String
Dim filepath As String

    Dim shs() As Variant                        
    Dim i As Integer, j As Integer            
'
Application.ScreenUpdating = False
Application.DisplayAlerts = False

strpath = ActiveWorkbook.Path
filepath = strpath & "\"

    For i = 2 To Sheets.Count              
        ReDim Preserve shs(j)               
        shs(j) = Worksheets(i).name      
        name1 = Worksheets(i).Range("B4").Value & "_Jan_2019"

fileName = Application.GetSaveAsFilename(filepath & name1 & name2 & name3, _
                                         FileFilter:="PDF Files (*.pdf), *.pdf", _
                                         Title:="Select Path and FileName to save")


    If fileName <> "False" Then

        With ActiveWorkbook

                .Worksheets(i).ExportAsFixedFormat Type:=xlTypePDF, fileName:= _
                    fileName, Quality:=xlQualityStandard, _
                    IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False 

        End With

    End If
                                
            j = j + 1     
    Next i                
                                
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Code: Select all

Sub RTP()

 Dim Ws As Worksheet
 Dim Rng As Range
 Dim Chrt As ChartObject
 Dim lWidth As Long, lHeight As Long
 Dim i As Integer
 
        For i = 2 To Sheets.Count
        Sheets(i).Select

                     Set Ws = ActiveSheet
                     Set Rng = Ws.Range("B3:O12")        ''' range to picture
                     '       Range("B3").Select
                     '       Range(Selection, Selection.End(xlDown)).Select
                     '       Range(Selection, Selection.End(xlToRight)).Select
                     ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png"      '"\img.png"
                     
                     Rng.CopyPicture xlScreen, xlPicture
                     lWidth = Rng.Width
                     lHeight = Rng.Height
                    
                     Set Chrt = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
                    
                     Chrt.Activate
                     With Chrt.Chart
                      .Paste
                      .Export fileName:=ExportPath, Filtername:="PNG"
                     End With
                     Chrt.Delete

        Next i
    Sheets("Assessment").Select
End Sub

Code: Select all

'Other code
For i = 2 To Sheets.Count
    With Sheets(i)
        'Set Ws = ActiveSheet
        Set Rng = .Range("B3", .Range("B" & .Rows.Count).End(xlUp)) _
            .Resize(, 14)
        '       Range("B3").Select
        '       Range(Selection, Selection.End(xlDown)).Select
        '       Range(Selection, Selection.End(xlToRight)).Select
        ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png"      '"\img.png"
        
        Rng.CopyPicture xlScreen, xlPicture
        lWidth = Rng.Width
        lHeight = Rng.Height
        
        Set Chrt = Ws.ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
        
        Chrt.Activate
        With Chrt.Chart
            .Paste
            .Export fileName:=ExportPath, Filtername:="PNG"
        End With
        Chrt.Delete
    End With
Next i
'Other code

Code: Select all

Sub RTB()

 Dim Rng As Range
 Dim Chrt As ChartObject
 Dim lWidth As Long, lHeight As Long
 Dim i As Integer

For i = 2 To Sheets.Count
    With Sheets(i)
                Sheets(i).Select
                Set Rng = .Range("B3", .Range("B" & .Rows.Count).End(xlUp)) _
                    .Resize(, 14)
        
                ExportPath = ThisWorkbook.Path & "\" & Range("C4").Value & ".png"
                
                Rng.CopyPicture xlScreen, xlPicture
                lWidth = Rng.Width
                lHeight = Rng.Height
                
                Set Chrt = .ChartObjects.Add(Left:=0, Top:=0, Width:=lWidth, Height:=lHeight)
                
                Chrt.Activate
                With Chrt.Chart
                    .Paste
                    .Export fileName:=ExportPath, Filtername:="PNG"
                End With
                Chrt.Delete
            End With
        Next i

    Sheets("Assessment").Select
End Sub