Dim iChartHeight As Integer
Dim iChartWidth As Integer
Dim iChartLeft As Integer
Sub WebDeliveryDate()
'JennyDrumm 06052015
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayAlerts = False
End With
'Sort raw data by Method
lr = Range("A" & Rows.count).End(xlUp).Row
Range("A" & "2" & ":S" & lr).Select
Selection.Sort Key1:=Range("P1"), Order1:=xlAscending
'Changes Methods to correct abbreviations and delete others
For i = lr To 2 Step -1
If Range("P" & i).Value = "APP" Then
Range("P" & i).Value = "USPS"
ElseIf Range("P" & i).Value = "DD" Then
Range("P" & i).Value = "2 Day"
ElseIf Range("P" & i).Value = "FEDXG" Then
Range("P" & i).Value = "Ground"
ElseIf Range("P" & i).Value = "FEDXH" Then
Range("P" & i).Value = "Home Delivery"
ElseIf Range("P" & i).Value = "ON" Then
Range("P" & i).Value = "Overnight"
Else
Rows(i & ":" & i).EntireRow.Delete
End If
Next i
'Insert blank row above each section
For lr = Cells(Cells.Rows.count, "P").End(xlUp).Row To 3 Step -1
If Cells(lr, "P") <> Cells(lr - 1, "P") Then
Rows(lr).EntireRow.Insert
End If
Next lr
'Select newly created blank rows
FS = Columns("P").Find(What:=Range("P3").Value, SearchDirection:=xlPrevious).Row
SS = Columns("P").Find(What:=Range("P" & FS + 2), SearchDirection:=xlPrevious).Row
TS = Columns("P").Find(What:=Range("P" & SS + 2), SearchDirection:=xlPrevious).Row
FS2 = Columns("P").Find(What:=Range("P" & TS + 2), SearchDirection:=xlPrevious).Row
'Paste header row in blank rows
With Range("A1:S1")
.Copy Range("A" & (FS + 1) & ":S" & (FS + 1) & ",A" & (SS + 1) & ":S" & (SS + 1) _
& ",A" & (TS + 1) & ":S" & (TS + 1) & ",A" & (FS2 + 1) & ":S" & (FS2 + 1))
End With
'Moves on to next subroutine - WorkingPivotTable2
WorkingPivotTable2
Range("N1").Select
ActiveWindow.ScrollRow = 1
'Sets print area
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.25)
.RightMargin = Application.InchesToPoints(0.25)
.TopMargin = Application.InchesToPoints(0.25)
.BottomMargin = Application.InchesToPoints(0.25)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
End Sub
Sub WorkingPivotTable2()
Dim mySheet As Worksheet, pivotSheet As Worksheet
Dim pc As PivotCache
Dim pt As PivotTable
Dim pf1 As PivotField
Dim pf2 As PivotField
Dim pf3 As PivotField
Dim pf4 As PivotField
Dim mydata As Range
Dim strFirstRowAddress As String, fromRow As Long, toRow As Long, _
lastRow As Long, boolRun As Boolean
Dim oCell As Range
Dim oPivotPos As Range, strPivotName As String, oldPivotRow As Long, _
newPivotRow As Long
Set mySheet = ActiveWorkbook.Sheets(1)
iChartHeight = 150
iChartWidth = 300
iChartLeft = 200
'If there is a sheet called Pivot Charts, this deletes it
On Error Resume Next
Application.DisplayAlerts = False
ActiveWorkbook.Sheets("Pivot Charts").Delete
Err.Clear
Application.DisplayAlerts = True
On Error GoTo 0
'Creates a new sheet called Pivot Charts
Sheets.Add After:=Sheets(1)
ActiveSheet.Name = "Pivot Charts"
Set pivotSheet = ActiveWorkbook.Sheets("Pivot Charts")
fromRow = 1
strFirstRowAddress = mySheet.Range("A1").Address
lastRow = mySheet.Range("A1").End(xlDown).Row
boolRun = True
Set oPivotPos = pivotSheet.Range("A1")
'Finds the next instance of the word Ticket in column A
Set oCell = mySheet.Range("A:A").Find(What:="Ticket", LookIn:=xlValues)
'This tells the macro to continue until it finds a cell in
'column A that is empty
While Not oCell Is Nothing And boolRun
'If next oCell row is not the same as the first one
'then toRow is the row above oCell
If oCell.Address <> strFirstRowAddress Then
toRow = oCell.Row - 1
Else
toRow = lastRow
boolRun = False
End If
'Names the Pivot Table "ItemList_(fromRow)_(toRow)"
'(Pivot Chart will have the same name)
strPivotName = "ItemList_" & fromRow & "_" & toRow
'Selects the data on the source sheet and creates the basic Table
Set mydata = mySheet.Range("A" & fromRow & ":S" & toRow)
Set pc = ActiveWorkbook.PivotCaches.Create(xlDatabase, mydata)
Set pt = pc.CreatePivotTable(oPivotPos, strPivotName)
'Sets up rows and data fields in table
Set pf1 = pt.PivotFields("Method")
pf1.Orientation = xlRowField
Set pf2 = pt.PivotFields("OutofRange")
pf2.Orientation = xlRowField
Set pf3 = pt.PivotFields("Tracking#")
pf3.Orientation = xlDataField
pf3.Function = xlCount
pf3.Caption = "Count"
Set pf4 = pt.PivotFields("Tracking#")
pf4.Orientation = xlDataField
pf4.Function = xlCount
pf4.Caption = "% of Method"
pf4.Calculation = xlPercentOfTotal
pf4.NumberFormat = "0.00%"
'Moves on to the next subroutine - CreatePivotChart2
CreatePivotChart2 pt.TableRange1, "Chart_" & fromRow & "_" & toRow
'Chooses the position for the next pivot table
oldPivotRow = oPivotPos.Row
'Sets the new Pivot table to be placed 4 rows
'below the end of the previous table
newPivotRow = pt.DataLabelRange.End(xlDown).Row + 4
'But, if the newPivotRow is above the end of the previous chart
'then the newPivotRow will be placed 2 rows below the previous chart
If ((newPivotRow - oldPivotRow) < (iChartHeight / _
pivotSheet.StandardHeight)) Then
newPivotRow = oldPivotRow + Round(iChartHeight / _
pivotSheet.StandardHeight) + 2
End If
'Sets oPivotPos as A in the newPivotRow
Set oPivotPos = pivotSheet.Range("A" & newPivotRow)
'Sets fromRow as previous toRow + 1
fromRow = toRow + 1
'Sets oCell to next row where A is Ticket
Set oCell = mySheet.Range("A:A").FindNext(oCell)
Wend
'Sets all charts with their left borders aligned.
For Each oCht In pivotSheet.ChartObjects
oCht.Left = 200
Next oCht
'Macro then goes back to sub WebDeliveryDate at the point it left
End Sub
Sub CreatePivotChart2(chartData As Range, chartName As String)
Dim chObj As ChartObject
Dim ch As Chart
Set mySheet = ActiveWorkbook.Sheets("Pivot Charts")
'Each time a new chart is created, if there's already a chart
'with that name, delete the old one
For Each oCht In mySheet.ChartObjects
If oCht.Name = chartName Then oCht.Delete
Next oCht
'Selects data in the Pivot Table to use in the Pivot Chart
chartData.Select
'Formats new Chart
Set chObj = mySheet.ChartObjects.Add(iChartLeft, chartData.Top + 1, _
iChartWidth + 148, iChartHeight)
chObj.Chart.ChartWizard Source:=chartData, gallery:=xlColumnClustered
chObj.Name = chartName
'Changes the % bars to a line and then makes that line invisible
chObj.Chart.SeriesCollection(2).ChartType = xlLine
chObj.Chart.SeriesCollection(2).Select
Selection.Format.Line.Visible = msoFalse
'Gets rid of the % button in the Legend
chObj.Chart.Legend.LegendEntries(2).Delete
'Macro then goes back to sub WorkingPivotTable at the point it left
End Sub