merciful
04-07-2017, 11:35 AM
Hi,
Below vba code is working perfectly in excel 2010, but not working in excel 2016. Actually i need export multiple pivot charts to folder. in red colour mentioned having the issues in excel 2016.
Sub Savetopic()
Dim i As Long
Dim j As Long
Dim shp As Shape
Dim cht As ChartObject
Dim StrPath As String
Dim shtnam As String
Dim A, B As String
j = 0
For i = 1 To Sheets.Count
If Sheets(i).Name = "Email" Then
j = i
End If
Next i
If j = 0 Or j = Sheets.Count Then Exit Sub
Application.DisplayAlerts = False
For i = Sheets.Count To j + 1 Step -1
StrPath = ActiveWorkbook.Path & Application.PathSeparator
Sheets(i).Select
shtnam = ActiveSheet.Name
ActiveSheet.Shapes.SelectAll
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp1"
ActiveSheet.Pictures.Paste.Select
With ActiveSheet
Set shp = .Shapes("Picture 1")
shp.Copy
shp.CopyPicture xlScreen, xlPicture
'// Depending on what's in the pic, you may need to add a few points to
'// hgt/wid
A = shp.Width
B = shp.Height
If shp.Width > 766 Then
shp.Width = 766
'shp.Height = 600
End If
Set cht = .ChartObjects.Add(0, 0, shp.Width, shp.Height)
cht.Chart.Paste
cht.Chart.Export StrPath & shtnam & ".jpg"
cht.Delete
Sheets("Temp1").Delete
End With
Set shp = Nothing
Set cht = Nothing
Next i
End Sub
Below vba code is working perfectly in excel 2010, but not working in excel 2016. Actually i need export multiple pivot charts to folder. in red colour mentioned having the issues in excel 2016.
Sub Savetopic()
Dim i As Long
Dim j As Long
Dim shp As Shape
Dim cht As ChartObject
Dim StrPath As String
Dim shtnam As String
Dim A, B As String
j = 0
For i = 1 To Sheets.Count
If Sheets(i).Name = "Email" Then
j = i
End If
Next i
If j = 0 Or j = Sheets.Count Then Exit Sub
Application.DisplayAlerts = False
For i = Sheets.Count To j + 1 Step -1
StrPath = ActiveWorkbook.Path & Application.PathSeparator
Sheets(i).Select
shtnam = ActiveSheet.Name
ActiveSheet.Shapes.SelectAll
Selection.Copy
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = "Temp1"
ActiveSheet.Pictures.Paste.Select
With ActiveSheet
Set shp = .Shapes("Picture 1")
shp.Copy
shp.CopyPicture xlScreen, xlPicture
'// Depending on what's in the pic, you may need to add a few points to
'// hgt/wid
A = shp.Width
B = shp.Height
If shp.Width > 766 Then
shp.Width = 766
'shp.Height = 600
End If
Set cht = .ChartObjects.Add(0, 0, shp.Width, shp.Height)
cht.Chart.Paste
cht.Chart.Export StrPath & shtnam & ".jpg"
cht.Delete
Sheets("Temp1").Delete
End With
Set shp = Nothing
Set cht = Nothing
Next i
End Sub