Skip to content

Instantly share code, notes, and snippets.

@walkergv
Last active Sep 26, 2019
Embed
What would you like to do?
A VBA Excel Macro that processes an Excel Table with a category column (must be first column) and applies several sorts, filters and styling. Also it creates a linked table of contents of worksheets in the excel workbook.
Sub CategoryToSheet()
Dim rng As Range
Dim Category As Range
Dim List As New Collection
Dim Item As Variant
Dim i As Integer
Dim rngLinkCell As Range
Dim strSubAddress As String
Dim strDisplayText As String
'
' Set the Field we want to Filter by (In this case the 5th column)
' Dim SortField As String: SortField = 5
'
'Some Titles for each catgorized worksheet.
Dim Title As String: Title = "Categorized Keywords"
Dim Source As String: Source = "www.tikodigital.com"
Dim PullDate As String: PullDate = "5/20/2012"
'
' We are going to work with a bunch of worksheets let's create some.
Dim Sh As Worksheet
Dim Sheet As Worksheet
Dim ShNew As Worksheet
Dim ShTableOfContents As Worksheet
'
' If you want to see changes happen on screen as the code runs
' Screen Updating = True, Leaving it false speeds things up
' as the screen doens't have to render.
Application.ScreenUpdating = True
'
' Set the source worksheet
Set Sh = Worksheets("Sheet1")
'
' Add A Worksheet to the Workbook called Table of Contents
Set ShTableOfContents = Worksheets.Add
ShTableOfContents.Name = "Table of Contents"
'
' Set Range to the first column of the table.
Set rng = Sh.ListObjects(1).ListColumns(1).DataBodyRange
' Loop throught the first column of the list and
' create a list of categories from unique values in the list.
On Error Resume Next
For Each Category In rng
List.Add Category.Value, CStr(Category.Value)
Next Category
On Error GoTo 0
'
' Reuse the range variable and change the data range to
' the entire ListObject (A.K.A. an Excel Table)
Set rng = Sh.ListObjects(1).Range
'
' Lets's loop through the list of categories
For Each Item In List
'
'Create a new worksheet For the List item
Set ShNew = Worksheets.Add
'
' The "With" command tells VBA to use the current new Worksheet
' It's just a shortcut so we don't have tow rewrite ShNew every
' time we refence the New Sheet.
With ShNew
'
' Give the new sheet the name of the category.
.Name = Left(Item, 30)
'
' Excel tables are aweome because they make filtering and sorting data easy
' Let's add filtering to each new table - Forexample I wonly want to see
' the top 40 keywords by Google Result and do some basic formatting.
' and remove the first auto generated column that is just going to contain the
' the category name in every row
rng.AutoFilter _
Field:=1, _
Criteria1:=Item
rng.SpecialCells(xlCellTypeVisible).Copy .Range("A1")
rng.AutoFilter
.ListObjects.Add(xlSrcRange, ShNew.UsedRange, , xlYes).Name = Item
.ListObjects(Item).TableStyle = "TableStyleLight9"
.ListObjects(Item).Range(1, 1).Select
.ListObjects(Item).ListColumns(1).Range.Delete
'.ListObjects(Item).Range.AutoFilter Field:=SortField - 1, Criteria1:="10", Operator:=xlTop10Items
.ListObjects(Item).Range.Columns.AutoFit
.ListObjects(Item).ListColumns(2).Range.ColumnWidth = "40"
'
' Let's add some fields above the Table to add some nice titles and style them
For i = 1 To 8
.Rows(1).EntireRow.Insert
Next i
.Columns("A").EntireColumn.Insert
.Columns("A").ColumnWidth = 5
.Range("B2").Value = Title
.Range("B2").Font.Size = 14
.Range("B2").Font.Bold = True
.Range("B3").Value = "Category:"
.Range("C3").Value = Item
.Range("B4").Value = "Source:"
.Range("C4").Value = Source
.Range("B5").Value = "Date of Pull:"
.Range("C5").NumberFormat = "@"
.Range("C5").Value = PullDate
'
' Let's add a link to the Table of Contents on each sheet
.Hyperlinks.Add Anchor:=.Range("B7"), _
Address:="", SubAddress:="'" & "Table of Contents" & "'!A1", _
TextToDisplay:="Return to Table of Contents"
'
' Turn off the gridlines on each new sheet.
' You don't need training wheels do you?
ActiveWindow.DisplayGridlines = False
' ############################################################################################
'
' GW: A bonus block of code for formatting the Active Sheet for printing
' this really slows down processing the data. I thought it would be
' because you can automate so much repetitve work.
'
' ############################################################################################
'
' Dim n As Integer: n = .ListObjects(Item).Range.Cells.Count
' .PageSetup.PrintArea = "$A$1:" & .ListObjects(Item).Range.Cells(n).Address
' .PageSetup.LeftHeader = ""
' .PageSetup.CenterHeader = ""
' .PageSetup.RightHeader = ""
' .PageSetup.LeftFooter = ""
' .PageSetup.CenterFooter = ""
' .PageSetup.RightFooter = ""
' .PageSetup.LeftMargin = Application.InchesToPoints(0.5)
' .PageSetup.RightMargin = Application.InchesToPoints(0.5)
' .PageSetup.TopMargin = Application.InchesToPoints(0.5)
' .PageSetup.BottomMargin = Application.InchesToPoints(0.5)
' .PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
' .PageSetup.FooterMargin = Application.InchesToPoints(0.5)
' .PageSetup.PrintHeadings = False
' .PageSetup.PrintGridlines = False
' .PageSetup.PrintComments = xlPrintNoComments
' .PageSetup.PrintQuality = 600
' .PageSetup.CenterHorizontally = False
' .PageSetup.CenterVertically = False
' .PageSetup.Orientation = xlLandscape
' .PageSetup.Draft = False
' .PageSetup.PaperSize = xlPaperLetter
' .PageSetup.FirstPageNumber = xlAutomatic
' .PageSetup.Order = xlDownThenOver
' .PageSetup.BlackAndWhite = False
' .PageSetup.Zoom = False
' .PageSetup.FitToPagesWide = 1
' .PageSetup.FitToPagesTall = 1
' .PageSetup.PrintErrors = xlPrintErrorsDisplayed
'
' ###########################################################################################
End With
Next Item
'
' For Each worksheet in the Entire Workbook Loop through create a
' Hyperlink to the Worksheet in the Table of Contents
For Each Sheet In ActiveWorkbook.Worksheets
Set rngLinkCell = ShTableOfContents.Range("A" & Rows.Count).End(xlUp)
If ShTableOfContents.Range("A1") = "" Then
Set rngLinkCell = Worksheets("Table of Contents").Range("A1")
End If
If rngLinkCell <> "" Then Set rngLinkCell = rngLinkCell.Offset(1, 0)
strSubAddress = "'" & Sheet.Name & "'!A1"
strDisplayText = Sheet.Name
Worksheets("Table of Contents").Hyperlinks.Add _
Anchor:=rngLinkCell, _
Address:="", _
SubAddress:=strSubAddress, _
TextToDisplay:=strDisplayText
Next Sheet
'
' Move the Table of Content to make it the First Worksheet in the Workbook
With ShTableOfContents
.Move Before:=Worksheets(1)
For i = 1 To 3
.Rows(1).EntireRow.Insert
Next i
'
' Let's add some fields above the Table of Content to add some nice titles and style them
.Columns("A").EntireColumn.Insert
.Range("B2").Value = "Table of Contents"
.Range("B2").Font.Size = 14
.Range("B2").Font.Bold = True
.Activate
End With
'
' Turn Off those Damn Gridlines
ActiveWindow.DisplayGridlines = False
End Sub
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment