'
' The purpose of this macro is to hide lines which have NOT been comment bookmarked
' Each first cell for a line will be checked whether it starts with "====== Bookmark Info ======"
' If no bookmarks exist the user will be notified about it and we will stay where we are.
' If we encounter a hidden bookmarked line we will automatically unhide it without asking.
'
' Fixed the handling of positioning the comment box. At times it happens it moves to a strange location far away from the cell it belongs to
' Fixed the handling of the row and comment height
'
' Macro created 14-06-2007 by Bob Becker Hof (HP)
' Tested with Excel 2003 and EVE 2.30 xls output format
' If the length of the file is huge the progress indicator at the top get an overflow (>200 characters) and get into the debugger.
'   We now check the length of the variable and if it exceeds 200 we take the last 197 characters and put three dots at the start.
'

Sub Comment_Bookmark_lines_Unmarked_Hide()

Dim crow As Long
Dim ccol As Long
Dim lasrow As Long
Dim lascol As Long
Dim trow As Long

Dim FirstRow As Long
Dim LastRow As Long
Dim FoundFirst As Boolean

Dim newrow As Boolean
Dim commentparentrow As Long

Dim csname As String
Dim prgname As String

Dim msg As String

Dim headercnt, colcnt, fnt As Long
Dim header As Variant                               ' First number represent the number of column headers within
                                                    ' the array called header
Dim headerfnd(4 - 1) As Integer                     ' First number represent the number of column headers within
                                                    ' the array called header

Dim headercolnr As Variant                          ' Column numbers for headers we are looking for in an array

Dim headersfound As Long                            ' Counter for checking the amount of columns we have found
Dim headerrow As Long                               ' Variable we use to store the row number where we have found our column headers
Dim headerrowcnt As Long                            ' For-Next variable used to loop through from the first row until the row as defined
                                                    ' by headerrowmax while trying to find the row containing all column headers
Dim headerrowmax As Long                            ' Maximum amount of headers we will have a look at while trying to find the header row
                                                    ' containing the column headers
Dim marked_cells As Boolean                                                 ' Boolean indicating we have marked cells on the current line or not
    
Dim stepsize As Double
Dim steprows As Double
Dim stepperc As String
Dim currentcaption As String

Dim MultiRange As Range
Dim Dummy As String

    
    Title = "Comment_Bookmark_lines_Unmarked_Hide"                       ' Define title.
    prgname = "%" + Title + ": "

    crow = ActiveCell.Row
    ccol = ActiveCell.Column
    lasrow = ActiveCell.SpecialCells(xlLastCell).Row
    lascol = ActiveCell.SpecialCells(xlLastCell).Column
    LastRow = 2
    FirstRow = lasrow
    FoundFirst = False

    commenttextstart = "====== Bookmark Info ======"
    commenttextend = commenttextstart
    commentcolumn = 1

' By default the xlLastCell.row funtion returns the last visible row
' But there might be more rows below it which are hidden so loop down until we hit a row which is NOT hidden
' Lets assume that 650000 is the maximum row number possible...
'
''    Debug.Print "Current Lasrow: " & Str(lasrow)
    For hidden_rows_behind_lasrow = lasrow To 650000 Step 1
        If Not (Range(Cells(hidden_rows_behind_lasrow + 1, 1).Address).EntireRow.Hidden) Then
            lasrow = hidden_rows_behind_lasrow
''            Debug.Print "New Lasrow    : " & Str(lasrow)
            Exit For
        End If
    Next

    csname = ActiveSheet.Name

' Temporarily stop screen updates to speed up the process
''    Application.ScreenUpdating = False
    currentcaption = ActiveWorkbook.Windows(1).Caption    ' Save current Window Caption

'
' Sometimes people decide to create comments which are "un_movable".
' Verify this sheet and if you find any change that :-)
' If we don't we might hit errors while trying to hide rows.
'

    On Error Resume Next
    For Each s In ActiveSheet.Shapes
        s.Placement = xlMoveAndSize
    Next
    On Error GoTo 0


' We would like to see how we are progressing even though we disable the screen updates...
    stepsize = lasrow / 10                           ' We display info each 10th time
    steprows = 0
    
    For trow = lasrow To 1 Step -1
''    For trow = 3570 To 1 Step -1
        
        steprows = steprows + 1
'
' Do we have to show where we are?
'
        If (steprows > stepsize) Then
            stepperc = currentcaption & " ==> Comment_Bookmark_lines_Unmarked_Hide progress... " & Int((lasrow - trow) / lasrow * 100) & " %"
            if len(stepperc) > 200 Then
            	stepperc = "..." & right(stepperc,197)
            End If
            Application.ScreenUpdating = True
            ActiveWorkbook.Windows(1).Caption = stepperc
            Application.ScreenUpdating = False
            steprows = 0                                    ' Count our steps again for our next intermediate result
        End If

        marked_cells = False
        
        Set rng = ActiveSheet.Cells(trow, commentcolumn)
        If Not (rng.Comment Is Nothing) Then
            currentcomment = rng.Comment.Text
''            Debug.Print prgname & "Cell at row " & crow & " column 1 has comment/bookmark set to """ & currentcomment & """ within worksheet " & csname
            If Left(currentcomment, Len(commenttextstart)) = commenttextstart Then
                marked_cells = True
' If the current comment bookmark is hidden make it visible again
                If (Range(Cells(trow, commentcolumn).Address).EntireRow.Hidden) Then
                    Range(Cells(trow, commentcolumn).Address).EntireRow.Hidden = False
                End If
            End If
        End If
        
        If Not marked_cells Then
            If Not FoundFirst Then
                FirstRow = trow
                FoundFirst = True
            End If
        Else
            If FoundFirst Then
                LastRow = trow + 1
''                Range(Rows(Trim(Str(LastRow)) + ":" + Trim(Str(FirstRow))).Address).Select
                Range(Rows(Trim(Str(LastRow)) + ":" + Trim(Str(FirstRow))).Address).EntireRow.Hidden = True
                FoundFirst = False
            End If
        End If
    Next

    If FoundFirst Then
        LastRow = trow + 1
''        Range(Rows(Trim(Str(LastRow)) + ":" + Trim(Str(FirstRow))).Address).Select
        Range(Rows(Trim(Str(LastRow)) + ":" + Trim(Str(FirstRow))).Address).EntireRow.Hidden = True
        FoundFirst = False
    End If

'
' Autosize all comment shapes
'

    For Each rng In ActiveSheet.Comments
        With rng
            .Shape.TextFrame.AutoSize = True
' Reposition comment just in case it stranded at another location. But only if the comment is visible
            If .Shape.Visible = True Then
                .Shape.Top = .Parent.Top + 5
                .Shape.Left = .Parent.Offset(0, 1).Left + 5
            End If

'
' Adjust row height based upon row and comment heigth
'
            
            If .Shape.Visible = True Then
                currentcomment = .Text
                If Left(currentcomment, Len(commenttextstart)) = commenttextstart Then
                    commentparentrow = .Parent.Row
                    Rows(commentparentrow).EntireRow.AutoFit
                    Rows(commentparentrow).EntireRow.RowHeight = .Shape.Height
                    .Shape.Height = Rows(commentparentrow).EntireRow.RowHeight
                End If
            End If

            If .Shape.Width > 300 Then
                lArea = .Shape.Width * .Shape.Height
                .Shape.Width = 200
                ' An adjustment factor of 1.1 seems to work ok.
                .Shape.Height = (lArea / 200) * 1.1
            End If
        End With
    Next

' Enable original windows caption again
    ActiveWorkbook.Windows(1).Caption = currentcaption
    
' Enable screen updates again
    Application.ScreenUpdating = True
    
'
' Position back to the original cell
'
    Cells(crow, ccol).Select
    
'
' If the current cell we where on is not comment bookmarked find the previous one (or wrap to the bottom and go up and find the first match from there)
'
    
    Set rng = ActiveSheet.Cells(crow, commentcolumn)
    If Not (rng.Comment Is Nothing) Then
        currentcomment = rng.Comment.Text
''        Debug.Print prgname & "Cell at row " & crow & " column 1 has comment/bookmark set to """ & currentcomment & """ within worksheet " & csname
        If Left(currentcomment, Len(commenttextstart)) <> commenttextstart Then
            Comment_Bookmark_lines_Previous_Match
        End If
    End If
    
End Sub