Saving all charts in active excel workbook to pdf file(s) using vba I would like

Question

Saving all charts in active excel workbook to pdf file(s) using vba

I would like my macro to create pdf files of seperate charts (which are in different worksheets) at the end of a Loop run/when macro has finished with main code. However, the number of worksheets can be any amount from 1 to a defined number (called LastTier).

The pdf filenames need to be in the format of: Client & " Tk" & TankNum & name of sheet chart is in

I am not sure how to do this as I am not that used to the VBA coding yet so would like a simple and easy code to be called into my main macro before the End Sub. If it is possible on Microsoft Windows 7: Home edition to compress these pdf files into a single file instead of 'n' amount of files then that would be great too. My code is below:

Sub Main2()

Dim Message As String
Dim Client As String
Dim StartDate As Date
Dim TankNum As String
Dim TankHeight As String
Dim LastTier As Integer
Dim increment As Integer

Dim Response As Long
Dim Msg As String
Dim Style As String
Dim Help As String
Dim Ctxt As Integer
Dim Tier As Integer

Dim K As Integer
Dim ender As Integer
Dim last As String
Dim starter As Integer
Dim sheetname1 As String
Dim Range1 As Range

Dim Devm As Single
Dim Rad As Double
Dim slice As String
Dim point As String
Dim Angle As Double
Dim Devmm As Integer
Dim height As String

Dim MainRange As Range
Dim CalcMode As Long
Dim ViewMode As Long
Dim sheetname2 As String
Dim SliceHeight As String

Call FileImport

Message = "Enter Client name"
Client = InputBox(Message, Title)

Message = "Enter the Tank ID"
TankNum = InputBox(Message, Title)

Message = "Enter job Start Date as dd/mm/yy"
StartDate = InputBox(Message, Title)

Message = "Enter the Full height of Tank"
TankHeight = InputBox(Message, Title)

Message = "Enter the number of slices"
LastTier = InputBox(Message, Title)

Message = "Enter the number of points"
increment = InputBox(Message, Title)

' ***********************************************************************
Do Until Response = vbNo

Msg = "Do you want to chart a slice?"
Style = vbYesNo + vbDefaultButton2
Help = "DEMO.HLP"
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbNo Then
Exit Do
Exit Sub
End If

Message = "Enter required slice number from 1 to " & LastTier
Tier = InputBox(Message, Title)
If IsNull(Tier) Then
Exit Sub
End If

K = 1
ender = Tier * increment
last = LastTier * increment
starter = ender - (increment - 1)
If starter = 0 Then
starter = 1
End If

sheetname1 = "Sheet1"
ActiveSheet.Name = sheetname1
ActiveSheet.Range("K2") = TankHeight
ActiveSheet.Range("K3") = LastTier - 1
ActiveSheet.Range("K4").Formula = "=$K$2/$K$3"
ActiveSheet.Range("K6").Value = 360
ActiveSheet.Range("K7") = increment
ActiveSheet.Range("K8").Formula = "=$K$6/$K$7"

Set Range1 = Range("A1:J" & (last + 10))
With Range1
Rows(last + 2).Delete
End With

For K = starter To ender
Devm = ActiveSheet.Range("A" & K).Value
Rad = ActiveSheet.Range("B" & K).Value
slice = ActiveSheet.Range("C" & K).Value
point = ActiveSheet.Range("D" & K).Value
' ***Automation settings for Formulas and Autofill - all in one***
ActiveSheet.Range("E1:E" & last).Formula = "=(D1-1)*$K$8"
ActiveSheet.Range("F1:F" & last).Formula = "=A1*1000"
ActiveSheet.Range("G1:G" & last).Formula = "=(C1-1)*$K$4"
Angle = ActiveSheet.Range("E" & K).Value
Devmm = ActiveSheet.Range("F" & K).Value
height = ActiveSheet.Range("G" & K).Value

K = K + 1

ActiveSheet.Range("C1").Select

Next

Set MainRange = ActiveSheet.Range("C1:G" & K)
MainRange.Parent.Select
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = True
.EnableEvents = False
End With

ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

MainRange.Parent.AutoFilterMode = False
MainRange.AutoFilter Field:=1, Criteria1:="=" & Tier

Sheets.Add
sheetname2 = "Slice" & Tier
ActiveSheet.Name = sheetname2
MainRange.Parent.AutoFilter.Range.Copy
With ActiveSheet.Range("A1")
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
If Tier > 1 Then
Rows(1).Delete
End If
End With

SliceHeight = ActiveSheet.Range("E2").Value
ActiveSheet.Range("A" & (increment + 1)).Formula = "=A1"
ActiveSheet.Range("B" & (increment + 1)).Formula = "=B1"
ActiveSheet.Range("C" & (increment + 1)).Formula = "=C1 + 360"
ActiveSheet.Range("D" & (increment + 1)).Formula = "=D1"
ActiveSheet.Range("E" & (increment + 1)).Formula = "=E1"

MainRange.Parent.AutoFilterMode = False
MainRange.Parent.Select
ActiveWindow.View = ViewMode
Call deviationcharts(Title, Client, StartDate, TankNum, increment, Tier, sheetname2, SliceHeight)
Sheets("Sheet1").Select

Loop
End Sub

Explanation / Answer

In your existing macro, at the desired point after the loop, insert the instruction:
Call aTest(Client)
and paste the following additional routine into your code module:

'==========>>
Public Sub aTest(sClient)
Dim WB As Workbook, newWB As Workbook
Dim CH As Chart
Dim Arr() As Variant
Dim i As Long

Set WB = ThisWorkbook
For Each CH In WB.Charts
With CH
i = i + 1
ReDim Preserve Arr(1 To i)
Arr(i) = .Name
End With
Next CH

sStr = sClient & Format(Date, "yyyymmdd")

With WB.Sheets(Arr)
.Copy
.ExptAsFixedFormat _
Type:=xlTypePDF, _
Filename:=sStr, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=True
End With
End Sub
'<<=============

Related Questions

Navigate

• Browse (All)
• Browse S
• Subjects

Integrity-first tutoring: explanations and feedback only — we do not complete graded work. Learn more.