Adding Tables using Excel VBA - excel

Question

I want to add new sheets and add tables in these new sheets, using vba. As shown in the image below, there are two column Main Category and Sub Category. I want to create new sheet for every Main Category and add tables for every Sub Category based on the sheet it belongs to. Additionally I may add new entries to Main Category and Sub Category, the vba code should add sheet and tables for those as well.
So far I am able to add the new sheets , but couldn't add the tables , This is what I have:
Sub CreateSheetsFromAList()
Dim MyCell As Range, myRange As Range
Dim MyCell1 As Range, myRange1 As Range
Dim WSname As String
Sheet1.Select
Range("A2").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Set myRange = Selection
Application.ScreenUpdating = False
For Each MyCell In myRange
If Len(MyCell.Text) > 0 Then
'Check if sheet exists
If Not SheetExists(MyCell.Value) Then
'run new reports code until before Else
Sheets.Add After:=Sheets(Sheets.Count) 'creates a new worksheet
Sheets(Sheets.Count).Name = MyCell.Value ' renames the new worksheet
WSname = MyCell.Value 'stores newly created sheetname to a string variable
'filters consolidated sheet based on newly created sheetname
Sheet3.Select
Range("A:T").AutoFilter
Range("D1").Select
Range("D1").AutoFilter Field:=4, Criteria1:=WSname, Operator:=xlFilterValues
Range("A1:U1").Select
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Range("A1:U" & lastRow).Select
Selection.Copy 'copies filtered data
'search and activate WSname
ChooseSheet WSname
Range("AH2").Select
ActiveCell.PasteSpecial xlPasteValues
Range("AJ:AJ").Select
Selection.NumberFormat = "hh:mm"
Range("B2").Select
End If
End If
Next MyCell
End Sub
Function SheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
SheetExists = Not sht Is Nothing
End Function
Public Sub ChooseSheet(ByVal SheetName As String)
Sheets(SheetName).Select
End Sub
End result looks like this:
Here's my sample workbook without any codes: https://drive.google.com/file/d/16logfbrvoK3CVKb-j-g4167pvU_BoWYI/view?usp=sharing

Answer 1

This approach should get you started.
Note: There are several TODOs in the code's comments.
Steps:
1) Convert your database range to an Excel structured table called (TableDatabase).
See this article
2) Add this code behind the sheet "Database"
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
DatabaseManager.Change Target
Application.ScreenUpdating = True
End Sub
3) Add a module and call it "DatabaseManager"
4) Add this code to the DatabaseManager module:
Option Explicit
Private Const DATABASE_TABLE_NAME As String = "TableDatabase"
Private Const DATABASE_MAINCAT_COLUMN_HEADER As String = "Main Category"
Private Const DATABASE_SUBCAT_COLUMN_HEADER As String = "Sub Category"
Private Const TABLE_OFFSET_ROWS As Long = 5
Private Const TABLE_COLUMN_LOCATION As Long = 1 ' 1 = A
Public Sub Change(ByVal Target As Range)
Dim databaseTable As ListObject
Dim tableRow As Long
Set databaseTable = Range(DATABASE_TABLE_NAME).ListObject
Select Case True
Case Not Intersect(Target, databaseTable.ListColumns(DATABASE_MAINCAT_COLUMN_HEADER).DataBodyRange) Is Nothing
' TODO: Validate if adding, updating or deleting a main category
' Case: Add a main category sheet
AddSheetByTitle Target.Value2, Target.Parent
' TODO: Case updating, deleting
Case Not Intersect(Target, databaseTable.ListColumns(DATABASE_SUBCAT_COLUMN_HEADER).DataBodyRange) Is Nothing
' TODO: Validate if adding, updating or deleting a sub category
tableRow = Target.Row - databaseTable.HeaderRowRange.Row + 1
' Case: Add a subcategory table
AddTableInSheetByName databaseTable.ListColumns(DATABASE_MAINCAT_COLUMN_HEADER).Range(tableRow), Target.Value2, Target.Parent
' TODO: Case updating, deleting
Case Else
End Select
End Sub
Public Function AddSheetByTitle(ByVal Title As String, Optional ByVal ReturnSheet As Worksheet) As Worksheet
' TODO: Validate if sheet name is valid
If SheetExists(Title) = True Then Exit Function
Dim newWorksheet As Worksheet
Set newWorksheet = ThisWorkbook.Worksheets.Add(after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
' Rename the new sheet
newWorksheet.Name = Title
' Return to a previous sheet
If Not ReturnSheet Is Nothing Then ReturnSheet.Activate
Set AddSheetByTitle = newWorksheet
End Function
Public Function AddTableInSheetByName(ByVal TargetSheetName As String, ByVal TableName As String, Optional ByVal ReturnSheet As Worksheet) As ListObject
Dim targetSheet As Worksheet
Dim targetTable As ListObject
Dim lastRow As Long
If SheetExists(TargetSheetName) = False Then
Set targetSheet = AddSheetByTitle(TargetSheetName)
End If
If TableExists(TableName) = True Then Exit Function
Set targetSheet = ThisWorkbook.Worksheets(TargetSheetName)
lastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row
Set targetTable = targetSheet.ListObjects.Add(SourceType:=xlSrcRange, Source:=targetSheet.Cells(lastRow, TABLE_COLUMN_LOCATION).Offset(TABLE_OFFSET_ROWS))
targetTable.Name = TableName
' Set table headers and content
targetTable.HeaderRowRange.Cells(1).Value2 = TableName
' Return to a previous sheet
If Not ReturnSheet Is Nothing Then ReturnSheet.Activate
End Function
Private Function SheetExists(ByVal SheetName As String) As Boolean
Dim evalSheet As Worksheet
On Error Resume Next
Set evalSheet = ThisWorkbook.Sheets(SheetName)
On Error GoTo 0
SheetExists = (Not evalSheet Is Nothing)
End Function
Private Function TableExists(ByVal TableName As String) As Boolean
Dim evalTable As ListObject
Dim evalName As String
' TODO: check if TableName is valid (search for invalid chars)
evalName = Replace(TableName, " ", "_")
On Error Resume Next
TableExists = (Range(evalName).ListObject.Name = TableName)
On Error GoTo 0
End Function
Note: Your end result belongs to an specific type of table. My code
adds (as you initially asked) a new table to the sheet. The alternative would be to copy (duplicate) a source table and rename it.
Hope this helps. Remember to mark the answer if it does.