samedi, juin 14, 2008

Excel visual basic macro generates table of contents

Excel visual basic macro generates table of contents that has one entry per worksheet.

download excel file


   1:rem Eric Mariacher
2:rem generate some charts and build a table of contents as 1st worksheet
3:Sub charts and TOC()
4: Dim ws As Worksheet
5: Dim cpt, cptpoint As Long
6: Dim color_index As Long
7: For Each ws In ActiveWorkbook.Worksheets
8: ActiveWorkbook.Activate
9: ws.Select
10: ws.Activate
11: Worksheets.Add
12: With ActiveSheet
13: .Name = "G" + ws.Name
14: Rem ch = .Controls.AddChart("B2:F7", "tagada")
15: End With
16: Charts.Add
17: ActiveChart.ChartType = xlColumnStacked
18: ActiveChart.SetSourceData Source:=Range(ws.Name), PlotBy:=xlColumns
19: With ActiveChart
20: .HasTitle = True
21: .ChartTitle.Characters.Text = ws.Name
22:
23: cpt = 1
24: For cpt = 1 To .SeriesCollection.Count
25: Select Case cpt
26: Case 1
27: color_index = 1
28: Case 2
29: color_index = 9
30: End Select
31: .SeriesCollection(cpt).Interior.ColorIndex = color_index
32: Next cpt
33: End With
34: ActiveChart.Location Where:=xlLocationAsObject, Name:="G" + ws.Name
35: With Worksheets("G" + ws.Name)
36: .ChartObjects(1).Width = 900
37: .ChartObjects(1).Height = 600
38: .ChartObjects(1).Left = .Columns("A").Left
39: .ChartObjects(1).Top = .Rows("2").Top
40: End With
41: Next ws
42:
43: Dim wsTOC As Worksheet
44: Dim Chart As Chart
45: Dim r As Long
46: Application.ScreenUpdating = False
47: Set wsTOC = ActiveWorkbook.Worksheets.Add _
48: (Before:=ActiveWorkbook.Sheets(1))
49: wsTOC.Name = "Table_of_Contents"
50: wsTOC.Range("A1") = "Table of Contents"
51: wsTOC.Range("A1").Font.Size = 18
52: wsTOC.Columns("A:A").ColumnWidth = 40
53: r = 3
54: For Each ws In ActiveWorkbook.Worksheets
55: If ws.Name <> wsTOC.Name And ws.Name Like "G*" Then
56: wsTOC.Hyperlinks.Add _
57: anchor:=wsTOC.Cells(r, 1), _
58: Address:="", _
59: SubAddress:=ws.Name & "!A1", _
60: TextToDisplay:=ws.Name
61: r = r + 1
62: ws.Hyperlinks.Add _
63: anchor:=ws.Cells(1, 1), _
64: Address:="", _
65: SubAddress:="Table_of_Contents!A1", _
66: TextToDisplay:="Table of Contents"
67: End If
68: Next
69: Application.ScreenUpdating = True
70:End Sub

Aucun commentaire: