Ok, aqui está o código que eu criei:
Type PageBreakLocation
Row As Long
Col As Long
Sheet As Long
End Type
Function GetLocationKey(item As PageBreakLocation)
GetLocationKey = "s" & item.Sheet & "r" & item.Row & "c" & item.Col
End Function
Type PageOfSheet
Sheet As Long
Page As Long
End Type
Sub CalcTableOfContents
used_pages = FindAllUsedPages()
page_of_each_sheet = GetPageOfEachSheet(used_pages)
Insert_TOC(page_of_each_sheet)
DisplayContents(page_of_each_sheet)
End Sub
Sub DisplayContents(page_of_each_sheet As Collection)
msg = ""
For Each value In page_of_each_sheet
sheet_name = ThisComponent.Sheets.getByIndex(value.Sheet).getName()
msg = msg & "Sheet(" & value.Sheet & ") """ & sheet_name & _
""" .....Page " & value.Page & CHR(13)
Next
MsgBox msg
End Sub
' Insert a Table of Contents into sheet 1.
Sub Insert_TOC(page_of_each_sheet As Collection)
oSheet = ThisComponent.Sheets.getByIndex(0)
oCell = oSheet.getCellByPosition(1, 1) 'B2
oCell.SetString("Table of Contents")
row = 3 ' the fourth row
For Each value In page_of_each_sheet
oCell = oSheet.getCellByPosition(1, row) ' column B
oCell.SetString(ThisComponent.Sheets.getByIndex(value.Sheet).getName())
oCell = oSheet.getCellByPosition(3, row) ' column D
oCell.SetString("Page " & value.Page)
row = row + 1
Next
End Sub
' Returns a collection with key as sheet number and item as page number.
Function GetPageOfEachSheet(used_pages As Collection)
Dim page_of_each_sheet As New Collection
page_number = 1
For Each used_page In used_pages
key = CStr(used_page.Sheet)
If Not Contains(page_of_each_sheet, key) Then
Dim value As New PageOfSheet
value.Sheet = used_page.Sheet
value.Page = page_number
page_of_each_sheet.Add(value, key)
End If
page_number = page_number + 1
Next
GetPageOfEachSheet = page_of_each_sheet
End Function
' Looks through all used cells and adds those pages.
' Returns a collection of used pages.
Function FindAllUsedPages
Dim used_pages As New Collection
For Each addr in GetFilledRanges()
FindPagesForRange(addr, used_pages)
Next
FindAllUsedPages = used_pages
End Function
' Returns an array of filled cells.
' Elements are type com.sun.star.table.CellRangeAddress.
' Note: oSheet.getPrintAreas() seemed like it might do this, but in testing,
' it always returned empty.
Function GetFilledRanges
allRangeResults = ThisComponent.createInstance( _
"com.sun.star.sheet.SheetCellRanges")
For i = 0 to ThisComponent.Sheets.getCount() - 1
oSheet = ThisComponent.Sheets.getByIndex(i)
With com.sun.star.sheet.CellFlags
printable_content = .VALUE + .DATETIME + .STRING + .ANNOTATION + _
.FORMULA + .OBJECTS
End With
filled_cells = oSheet.queryContentCells(printable_content)
allRangeResults.addRangeAddresses(filled_cells.getRangeAddresses(), False)
Next
' Print allRangeResults.getRangeAddressesAsString()
GetFilledRanges = allRangeResults.getRangeAddresses()
End Function
' Looks through the range and adds any pages to used_pages.
' Note: row.IsStartOfNewPage is only for manual breaks, so we do not use it.
Sub FindPagesForRange(range As Object, used_pages As Collection)
oSheet = ThisComponent.Sheets.getByIndex(range.Sheet)
aPageBreakArray = oSheet.getRowPageBreaks()
Dim used_row_breaks() As Variant
Dim used_col_breaks() As Variant
prev_break_row = 0
For nIndex = 0 To UBound(aPageBreakArray())
break_row = aPageBreakArray(nIndex).Position
If break_row = range.StartRow Then
Append(used_row_breaks, break_row)
ElseIf break_row > range.StartRow Then
Append(used_row_breaks, prev_break_row)
End If
If break_row > range.EndRow Then
Exit For
End If
prev_break_row = break_row
Next
prev_break_col = 0
aPageBreakArray = oSheet.getColumnPageBreaks()
For nIndex = 0 To UBound(aPageBreakArray())
break_col = aPageBreakArray(nIndex).Position
If break_col = range.StartColumn Then
Append(used_col_breaks, break_col)
ElseIf break_col > range.StartColumn Then
Append(used_col_breaks, prev_break_col)
End If
If break_col > range.EndColumn Then
Exit For
End If
prev_break_col = break_col
Next
For Each row In used_row_breaks()
For Each col In used_col_breaks()
Dim location As New PageBreakLocation
location.Sheet = range.Sheet
location.Row = row
location.Col = col
key = GetLocationKey(location)
If Not Contains(used_pages, key) Then
used_pages.Add(location, key)
End If
Next col
Next row
End Sub
' Returns True if the collection contains the key, otherwise False.
Function Contains(coll As Collection, key As Variant)
On Error Goto ErrorHandler
coll.Item(key)
Contains = True
Exit Function
ErrorHandler:
If Err <> 5 Then
MsgBox "Error " & Err & ": " & Error$ & " (line : " & Erl & ")"
End If
Contains = False
End Function
' Append an element to an array, increasing the array's size by 1.
Sub Append(array() As Variant, new_elem As Variant)
old_len = UBound(array)
ReDim Preserve array(old_len + 1) As Variant
array(old_len + 1) = new_elem
End Sub
É provavelmente uma boa ideia colocar esse código em seu próprio módulo, já que é muito grande. Então, para executá-lo, vá para Tools -> Macros -> Run Macro e execute a rotina CalcTableOfContents .
Para conseguir os números de página corretos, há um truque importante. O código só verifica o número da página de cada célula. Então, se o conteúdo de uma célula cruzar duas páginas, contará apenas a primeira página.
Para corrigir esse problema, adicione algum conteúdo em uma célula na segunda página. Defina como não imprimível indo até Format -> Cells -> Cell Protection e marcando "Ocultar ao imprimir". Isso forçará a macro a reconhecer a segunda página.
Se tudo correr bem, deve mostrar um resultado como este na planilha 1:
Créditos:
- Emboraelenãoofereçaumasolução,Villeroypesquisoubastanteesseproblema,porexemplo link .
- As coleções foram uma grande ajuda para escrever o código no Basic, conforme solicitado. Não há praticamente nenhuma documentação, mas veja o link . Além disso, a documentação do VB6 é relevante.
- Pergunta relacionada: link .