Solved: Creating multiple charts formatted the same

[MRichmond]

I have a table of data. This table is used to produce a number of league tables. I have an existing macro that works fine for this portion of the task.

I now need to create a number of bar charts from this data, and rather than having to go in and set up 15-20 (number can change) individually, I am looking for a macro that can do this for me.

I am attaching a sample workbook, showing what I have and what I am looking for help on.

Thanks for the help.

[Bob Phillips]

This addresses the variable data



Public Sub LeagueTables()
Dim wsLeague As Worksheet
Dim rng As Range
Dim Lastrow As Long

Application.ScreenUpdating = False

Set wsLeague = Worksheets("League Table Wsheet")

'Create, copy & sort site league table
With Worksheets("Site League Table")

.Columns("A:H").Delete Shift:=xlToLeft

wsLeague.Cells.AutoFilter Field:=18, Criteria1:="1"
Lastrow = wsLeague.Cells(wsLeague.Rows.Count, "K").End(xlUp).Row
wsLeague.Range("K1").Resize(Lastrow, 7).Copy .Range("A1")

Call FormatAndSort(.Range("A1:G1"), .Range("G2"), xlDescending, .Range("E2"), xlDescending)

.Columns("B:B").Cut
.Columns("A:A").Insert Shift:=xlToRight
End With


'Create, copy & sort contractor league table
With Worksheets("Contractor League Table")

.Columns("A:D").Delete Shift:=xlToLeft

wsLeague.Cells.AutoFilter Field:=18
wsLeague.Cells.AutoFilter Field:=10, Criteria1:="1"
Lastrow = wsLeague.Cells(wsLeague.Rows.Count, "F").End(xlUp).Row
wsLeague.Range("F1").Resize(Lastrow, 4).Copy .Range("A1")

Call FormatAndSort(.Range("A1:D19"), .Range("D2"), xlDescending, .Range("B2"), xlDescending)
End With

'Create, copy & sort PM League table
With Worksheets("PM League Table")

.Columns("A:D").Delete Shift:=xlToLeft

wsLeague.Cells.AutoFilter Field:=10
wsLeague.Cells.AutoFilter Field:=5, Criteria1:="1"
Lastrow = wsLeague.Cells(wsLeague.Rows.Count, "A").End(xlUp).Row
wsLeague.Range("A1").Resize(Lastrow, 4).Copy
.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

Call FormatAndSort(.Range("A1:D8"), .Range("D2"), xlDescending, .Range("B2"), xlDescending)
End With

Worksheets("League Table Wsheet").Cells.AutoFilter Field:=5

Application.ScreenUpdating = True
End Sub

Private Function FormatAndSort( _
ByRef rng As Range, _
ByVal Key1 As Range, ByVal Order1 As XlSortOrder, _
ByVal Key2 As Range, ByVal Order2 As XlSortOrder)
With rng

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Font.ColorIndex = 0

With .Rows(1)

With .Interior

.ColorIndex = 35
.Pattern = xlSolid
End With

.Font.Bold = True
End With

.Cells.EntireColumn.AutoFit

.Sort Key1:=Key1, Order1:=Order1, _
Key2:=Key2, Order2:=Order2, _
Header:=xlYes
End With
End Function

[MRichmond]

Thanks XLD, but two things:

First of all the macro fails when it reaches here
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
Secondly, the site league table doesn't appear to be sorting correctly (all the others do though)

[Bob Phillips]

I'll check that out, working on the charts at the moment.

[Bob Phillips]

I can't replicate the error. I thought it might be Excel 2003, but it works fine here in Excel 2003 as well.

I did find a couple of problems with the variability though



Option Explicit

Public Sub LeagueTables()
Dim wsLeague As Worksheet
Dim rng As Range
Dim Lastrow As Long

Application.ScreenUpdating = False

Set wsLeague = Worksheets("League Table Wsheet")

'Create, copy & sort site league table
With Worksheets("Site League Table")

.Columns("A:H").Delete Shift:=xlToLeft

wsLeague.Cells.AutoFilter Field:=18, Criteria1:="1"
Lastrow = wsLeague.Cells(wsLeague.Rows.Count, "K").End(xlUp).Row
wsLeague.Range("K1").Resize(Lastrow, 7).Copy .Range("A1")

Call FormatAndSort(.Range("A1:G1").Resize(Lastrow), .Range("G2"), xlDescending, .Range("E2"), xlDescending)

.Columns("B:B").Cut
.Columns("A:A").Insert Shift:=xlToRight
End With


'Create, copy & sort contractor league table
With Worksheets("Contractor League Table")

.Columns("A:D").Delete Shift:=xlToLeft

wsLeague.Cells.AutoFilter Field:=18
wsLeague.Cells.AutoFilter Field:=10, Criteria1:="1"
Lastrow = wsLeague.Cells(wsLeague.Rows.Count, "F").End(xlUp).Row
wsLeague.Range("F1").Resize(Lastrow, 4).Copy .Range("A1")

Call FormatAndSort(.Range("A1:D1").Resize(Lastrow), .Range("D2"), xlDescending, .Range("B2"), xlDescending)
End With

'Create, copy & sort PM League table
With Worksheets("PM League Table")

.Columns("A:D").Delete Shift:=xlToLeft

wsLeague.Cells.AutoFilter Field:=10
wsLeague.Cells.AutoFilter Field:=5, Criteria1:="1"
Lastrow = wsLeague.Cells(wsLeague.Rows.Count, "A").End(xlUp).Row
wsLeague.Range("A1").Resize(Lastrow, 4).Copy
.Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats

Call FormatAndSort(.Range("A1:D1").Resize(Lastrow), .Range("D2"), xlDescending, .Range("B2"), xlDescending)
End With

Worksheets("League Table Wsheet").Cells.AutoFilter Field:=5

Application.ScreenUpdating = True
End Sub

Private Function FormatAndSort( _
ByRef rng As Range, _
ByVal Key1 As Range, ByVal Order1 As XlSortOrder, _
ByVal Key2 As Range, ByVal Order2 As XlSortOrder)
With rng

.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
With .Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With .Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
.Font.ColorIndex = 0

With .Rows(1)

With .Interior

.ColorIndex = 35
.Pattern = xlSolid
End With

.Font.Bold = True
End With

.Cells.EntireColumn.AutoFit

.Sort Key1:=Key1, Order1:=Order1, _
Key2:=Key2, Order2:=Order2, _
Header:=xlYes
End With
End Function

[Bob Phillips]

Here's some code for the charts



Option Explicit

Public Function CreateCharts()
Dim ws As Worksheet
Dim rng As Range
Dim chrt As Chart
Dim thisArea As String
Dim lastrow As Long
Dim i As Long

Application.ScreenUpdating = False

With ThisWorkbook

Application.DisplayAlerts = False

For Each ws In .Worksheets

If Left$(ws.Name, 5) = "Chart" Then

ws.Delete
End If
Next ws

Application.DisplayAlerts = True

With .Worksheets("League Table Wsheet")

.Cells.AutoFilter

lastrow = .Cells(.Rows.Count, "K").End(xlUp).Row
For i = 2 To .Cells(.Rows.Count, "F").End(xlUp).Row

.Select
thisArea = .Cells(i, "F").Value2
Set ws = .Parent.Worksheets.Add(After:=.Parent.Worksheets(.Parent.Worksheets.Count))
ws.Name = "Chart " & thisArea
.Cells.AutoFilter Field:=12, Criteria1:=thisArea
On Error Resume Next
Set rng = .Range("K1:Q1").Resize(lastrow).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then

rng.Copy ws.Range("A1")
ws.Columns("B:F").Delete

Set chrt = Charts.Add
chrt.Name = "chart" & Replace(thisArea, " ", "")
chrt.ChartType = xlColumnClustered
chrt.SetSourceData Source:=ws.Range(ws.Range("A1"), ws.Range("B1").End(xlDown)), PlotBy:=xlColumns
chrt.ChartTitle.Characters.Text = thisArea
chrt.Location Where:=xlLocationAsObject, Name:=ws.Name
End If
Next i

.Cells.AutoFilter
.Select
End With
End With

Application.ScreenUpdating = True
End Function

[MRichmond]

Sorry XLD I'm being a bit thick, I cant seem to get the Chart macro to run (i cant even find it in the list of macro's to run). Any ideas?

Seem to have sorted the other two issues though

[Bob Phillips]

That is because I have used a function. Just type the name in the combobox, that works fine.

[MRichmond]

Now I am reall thick, what combobox should i be using. Do I create one, and if so from Control or Forms?

[Bob Phillips]

This one

[MRichmond]

Told you I was thick :doh:

That works for me XLD, couple of minor issues I can live with, coz what you haven given me will save me ages.

Thanks for your help XLD, as usual, you are the man.

:beerchug: