Printable View
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.
This addresses the variable data
[vba]
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[/vba]
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)
I'll check that out, working on the charts at the moment.
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
[vba]
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
[/vba]
Here's some code for the charts
[vba]
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[/vba]
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
That is because I have used a function. Just type the name in the combobox, that works fine.
Now I am reall thick, what combobox should i be using. Do I create one, and if so from Control or Forms?
This one
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: