Set objShell = CreateObject("Shell.Application")

    For Each wd In objShell.Windows

        If InStr(wd.document.Title, "College") = 1 Then
           Exit For
        End If
    Next wd

    Worksheets("BTS").Cells(2, 2).Value = wd.LocationURL

Dim objShell, sTitle, wd

Set objShell = CreateObject("Shell.Application")

For Each wd In objShell.Windows
    sTitle = ""
    On Error Resume Next
    sTitle = wd.document.Title
    On Error Goto 0
    If InStr(sTitle, "College") = 1 Then
       Exit For
    End If
Next wd

Worksheets("BTS").Cells(2, 2).Value = wd.LocationURL