VBA code to resolve overlapping page ranges

When preparing excerpts of pages from a deposition transcript for cited ranges in a court filing, it may be quite common to end up with a list of beginning and ending page ranges in two columns. It would be nice to simply take those ranges, insert a hyphen in between the beginning and ending of each range, and a comma between each individual range to set an extraction range in Adobe Acrobat, so you end up with the PDF that you need.

However, it's quite likely that in this situation you'll end up with many overlapping ranges where one range appears in the middle of the range listed before it, or the range begins in the midway point of a preceding range, but then ends several pages after it.

It's possible to easily generate a list of page ranges that account for all pages in your list, but which don't overlap and which don't include duplicates. Be sure to list the ranges in columns A and B, and then sort the data in order by the beginning pages before running the code.

After running the macro, the ranges will be listed in columns D and E:

. . . the input for the extraction in Acrobat then goes like this:

Sub ConsolidatePageRanges()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim s As Long, e As Long
    Dim nextOutputRow As Long

    ' Set the worksheet to the active sheet
    Set ws = ActiveSheet

    ' Ensure data is sorted by Start Page for this logic to work correctly
    ' You might want to manually sort Column A first if needed

    ' Find the last row with data in column A
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row

    ' Check if there is data to process
    If lastRow < 2 Then
        MsgBox "No data to process (need at least one row besides header).", vbInformation
        Exit Sub
    End If

    ' Initialize the first range
    s = ws.Cells(2, 1).Value
    e = ws.Cells(2, 2).Value

    ' Set output location (e.g., Column D and E, starting from row 2)
    nextOutputRow = 2
    ws.Cells(1, 4).Value = "Consolidated Start"
    ws.Cells(1, 5).Value = "Consolidated End"

    ' Loop through the rest of the data
    For i = 3 To lastRow
        ' If the current start page is greater than the current consolidated end page,
        ' the ranges do not overlap, so write the consolidated range and start a new one.
        If ws.Cells(i, 1).Value > e Then
            ws.Cells(nextOutputRow, 4).Value = s
            ws.Cells(nextOutputRow, 5).Value = e
            nextOutputRow = nextOutputRow + 1
            s = ws.Cells(i, 1).Value
            e = ws.Cells(i, 2).Value
        Else
            ' If they overlap, extend the current consolidated end page if the new end page is greater.
            If ws.Cells(i, 2).Value > e Then
                e = ws.Cells(i, 2).Value
            End If
        End If
    Next i

    ' Write the last consolidated range
    ws.Cells(nextOutputRow, 4).Value = s
    ws.Cells(nextOutputRow, 5).Value = e

    MsgBox "Ranges consolidated successfully in columns D and E.", vbInformation

End Sub

Visual Basic Code to Find and Replace Multiple Hyperlinks

Tonight, with the help of Copilot, I was able to generate the below vba code which will go through an Excel workbook, finding and replacing multiple static hyperlinks (not entered with an active formula) with new hyperlinks.

The code is set to work on both links to network filepaths, and to web-based urls. However filepaths which reference a network drive letter, should be converted to full UNC file paths, which include the server name. So instead of "P:\Acme\Trial\Closing.pptx", the path should be entered as "\\dewey.local\chi07\AL\Usershare"

[If you need help finding the full UNC file path for files on your network enter the command, 'net use' in command prompt and it will generate a list of the server paths for each drive you're mapped to.

Adding find and replace pairs to the vba code is easy. The old path is simply preceded by 'linkMap.Add' and then the two paths are enclosed in quotes and separated with a comma.

I tested the code tonight with a few hundred urls and the workbook was updated almost instantly.

Sub ReplaceNetworkDriveHyperlinks()

Dim ws As Worksheet

Dim hl As Hyperlink

Dim linkMap As Object

Dim oldLink As Variant

' Create a dictionary to store old and new network path mappings

Set linkMap = CreateObject("Scripting.Dictionary")

' Add your old and new UNC path pairs here

linkMap.Add "\\Server1\Shared\Docs\Report1.pdf", "\\Server2\Archive\Docs\Report1.pdf"

linkMap.Add "\\Server1\Shared\Docs\Report2.pdf", "\\Server2\Archive\Docs\Report2.pdf"

linkMap.Add "\\Server1\Shared\Images\", "\\Server2\Archive\Images\"

' Loop through all worksheets

For Each ws In ThisWorkbook.Worksheets

' Loop through all hyperlinks in the worksheet

For Each hl In ws.Hyperlinks

For Each oldLink In linkMap.Keys

If InStr(1, hl.Address, oldLink, vbTextCompare) > 0 Then

' Replace the old part of the path with the new one

hl.Address = Replace(hl.Address, oldLink, linkMap(oldLink))

hl.TextToDisplay = Replace(hl.TextToDisplay, oldLink, linkMap(oldLink)) ' Optional

End If

Next oldLink

Next hl

Next ws

MsgBox "Network hyperlinks updated successfully!", vbInformation

End Sub

The views expressed in this blog are those of the owner and do not reflect the views or opinions of the owner’s employer. All content provided on this blog is for informational purposes only. The owner of this blog makes no representations as to the accuracy or completeness of any information on this site or found by following any link on this site. The owner will not be liable for any errors or omissions in this information nor for the availability of this information. The owner will not be liable for any losses, injuries, or damages from the display or use of this information. This policy is subject to change at any time.  The owner is not an attorney, and nothing posted on this site should be construed as legal advice.   Litigation Support Tip of the Night does not provide confirmation that any e-discovery technique or conduct is compliant with legal, regulatory, contractual or ethical requirements.  

finding broken links in Excel

The Tip of the Night for May 8, 2015 concerned a macro that will check to see if links on an Excel spreadsheet are active.

The vba code below is an improvement. The code I posted about back in 2015 will generate a new worksheet in your spreadsheet with a list of the filepaths that don't work:

This vba code, posted here by Eawyne, creates a new spreadsheet which lists all of the links, and also indicates which cells the links appear in. [Be sure to use the version posted by Eawyne on 11/18/21 - not the one below it - it will give you incorrect results.]

Refer to column C to see which links do and do not exist. The linked to text appears in column H, and the cell of the original link is indicated in column B.

The code as written by Eawyne will stop after checking 1000 links. It can easily be modified by changing this line:

ReDim arr(1 To 1000, 1 To 9)

Increase the '1000' on this line of code to 9999, or whatever value you need.

It is also set to review links on multiple worksheets - something the older vba code did not do.

Public Sub CollectHyperlinks()

Dim Sht As Worksheet, Hl As Hyperlink, FSO As Object

Dim arr() As Variant, i As Long, Anchor As Object

Dim FileMsg As String, AnchorMsg As String

ReDim arr(1 To 1000, 1 To 9)

Set FSO = CreateObject("Scripting.FileSystemObject")

i = 1

arr(i, 1) = "Worksheet"

arr(i, 2) = "Hyperlink Anchor"

arr(i, 3) = "File"

arr(i, 4) = "Hyperlink Name"

arr(i, 5) = "Hyperlink Address"

arr(i, 6) = "SubAddress"

arr(i, 7) = "ScreenTip"

arr(i, 8) = "TextToDisplay"

arr(i, 9) = "EmailSubject"

For Each Sht In ThisWorkbook.Worksheets

For Each Hl In Sht.Hyperlinks

Set Anchor = Nothing

AnchorMsg = ""

FileMsg = ""

With Hl

If FSO.FileExists(.Address) Then FileMsg = "Exists"

On Error Resume Next

Set Anchor = .Range

If Not Anchor Is Nothing Then

AnchorMsg = Anchor.Address

Else

Set Anchor = .Shape

If Not Anchor Is Nothing Then

AnchorMsg = Anchor.Name

End If

End If

i = i + 1

arr(i, 1) = Sht.Name

arr(i, 2) = AnchorMsg

arr(i, 3) = FileMsg

arr(i, 4) = .Name

arr(i, 5) = .Address

arr(i, 6) = .SubAddress

arr(i, 7) = .ScreenTip

arr(i, 8) = .TextToDisplay

arr(i, 9) = .EmailSubject

On Error GoTo 0

End With

Next Hl

Next Sht

Application.ScreenUpdating = False

With Application.Workbooks.Add.Sheets(1)

.Range("A2").Select

ActiveWindow.FreezePanes = True

With .Rows("1:1")

.Interior.Color = 10837023

.Font.Color = RGB(255, 255, 255)

.Font.Bold = True

End With

.Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

.Columns("A:I").Columns.AutoFit

End With

Application.ScreenUpdating = True

End Sub