How to create an index list containing the title tables in one worksheet in excel - VBA

Question

There are a lot of VBA examples that produce and index list containing the name of the excel sheets (with hyperlinks).

Based on that, lets say we have:

• An undefinite number of crosstables in one excel sheet.
• A title exactly before each table (which are not actual tables from excel but cell ranges).
• First title is always in range A4.
• Always one empty row between tables.

Could we identify with VBA the cells where the titles are and create an index list with them?

Answer 1

Create an Index List of Tables in a Worksheet

Sub CreateTableList()

    ' Define constants.

    Const SRC_NAME As String = "Sheet1"
    Const SRC_FIRST_CELL As String = "A4"
    Const SRC_EMPTY_ROWS As Long = 1 ' has to be > 0
    
    Const DST_NAME As String = "List"
    Const DST_FIRST_CELL As String = "A1"
    Dim dHeaders(): dHeaders = VBA.Array("ID", "Table Name", "Table Rows")
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
    Dim sCell As Range: Set sCell = sws.Range(SRC_FIRST_CELL)
    Dim srg As Range: Set srg = sCell.CurrentRegion
    Dim srCount As Long: srCount = srg.Rows.Count
    
    If srCount = 1 Then
        MsgBox "No data found.", vbCritical
        Exit Sub
    End If
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")

    Do While srCount > 1
        dict(srg.Cells(1)) = srCount - 2
        Set sCell = sCell.Offset(srCount + SRC_EMPTY_ROWS)
        Set srg = sCell.CurrentRegion
        srCount = srg.Rows.Count
    Loop
    
    ' Destination
    
    Application.ScreenUpdating = False
    
    Dim dws As Worksheet
    
    ' Check if the destination worksheet exists.
    On Error Resume Next
        Set dws = wb.Sheets(DST_NAME)
    On Error GoTo 0
    
    ' Delete it if it exists.
    If Not dws Is Nothing Then
        Application.DisplayAlerts = False
            dws.Delete
        Application.DisplayAlerts = True
    End If
    
    ' Add new.
    Set dws = wb.Sheets.Add(Before:=wb.Sheets(1)) ' first
    dws.Name = DST_NAME
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    Dim dhrg As Range: Set dhrg = dfCell.Resize(, UBound(dHeaders) + 1)
    Dim ddrg As Range: Set ddrg = dhrg.Offset(1).Resize(dict.Count)
    
    ' Copy and format.
        
    With dhrg ' headers
        .Value = dHeaders
        .Font.Bold = True
    End With
    With ddrg ' data
        .Columns(1).Value = dws.Evaluate("ROW(1:" & dict.Count & ")")
        .Columns(2).Value = Application.Transpose(dict.Keys)
        .Columns(3).Value = Application.Transpose(dict.Items)
        .EntireColumn.AutoFit
    End With
        
    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "List created.", vbInformation
        
End Sub