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?

CodePudding user response：

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