Public Sub GetURLs()
    Dim URLSheet As Worksheet
    Dim URLSheetRow As Long
    Dim URLSheetRange As Range
    Dim SitemapSheet As Worksheet
    Dim SitemapSheetLastRow As Long
    Dim SitemapSheetRow As Long
    Dim TempXMLSheet As Worksheet
    Dim TempXMLSheetLastRow As Long
    Dim TempXMLSheetRow As Long
    Dim TempXMLSheetCellItemValue As Variant


    GetSitemaps

    Set URLSheet = Sheets("URLs")
    Set SitemapSheet = Sheets("Sitemaps")
    Set TempXMLSheet = Sheets("TempXML")

    While ActiveWorkbook.XmlMaps.Count > 0
        ActiveWorkbook.XmlMaps(1).Delete
    Wend

    URLSheet.Columns(1).Clear
    URLSheet.Columns(2).Clear
    URLSheet.Columns(3).Clear
    TempXMLSheet.Columns(1).Delete
    TempXMLSheet.Columns(1).Delete
    URLSheetRow = 1
    SitemapSheetLastRow = SitemapSheet.Range("A" & Rows.Count).End(xlUp).Row

    For SitemapRow = 1 To SitemapSheetLastRow
        ActiveWorkbook.XmlImport SitemapSheet.Cells.Item(SitemapRow, 1).Value, Nothing, True, TempXMLSheet.Range("A1")
        TempXMLSheetLastRow = TempXMLSheet.Range("A" & Rows.Count).End(xlUp).Row

        For TempXMLSheetRow = 1 To TempXMLSheetLastRow
            TempXMLSheetCellItemValue = TempXMLSheet.Cells.Item(TempXMLSheetRow, 1).Value

            If LCase(Left(CStr(TempXMLSheetCellItemValue), 4)) = "http" Then
                URLSheet.Cells.Item(URLSheetRow, 1).Value = TempXMLSheetCellItemValue
                URLSheet.Cells.Item(URLSheetRow, 2).Value = TempXMLSheet.Cells.Item(TempXMLSheetRow, 2).Value
                URLSheetRow = URLSheetRow + 1
            End If
        Next TempXMLSheetRow

        While ActiveWorkbook.XmlMaps.Count > 0
            ActiveWorkbook.XmlMaps(1).Delete
        Wend

        TempXMLSheet.Columns(1).Delete
        TempXMLSheet.Columns(1).Delete
    Next SitemapRow

    Set URLSheetRange = URLSheet.Range("A1", "B" & CStr(URLSheetRow - 1))
    URLSheetRange.Sort URLSheet.Range("B1")
End Sub

Public Sub GetSitemaps()
    Dim SitemapSheet As Worksheet
    Dim SitemapSheetRow As Long
    Dim TempXMLSheet As Worksheet
    Dim TempXMLSheetLastRow As Long
    Dim TempXMLSheetRow As Long


    Set SitemapSheet = Sheets("Sitemaps")
    Set TempXMLSheet = Sheets("TempXML")

    While ActiveWorkbook.XmlMaps.Count > 0
        ActiveWorkbook.XmlMaps(1).Delete
    Wend

    TempXMLSheet.Columns(1).Delete
    TempXMLSheet.Columns(1).Delete
    SitemapSheet.Columns(1).Clear

    ActiveWorkbook.XmlImport "https://support.microsoft.com/sitemap_index", Nothing, True, TempXMLSheet.Range("A1")
    TempXMLSheetLastRow = TempXMLSheet.Range("A" & Rows.Count).End(xlUp).Row
    SitemapSheetRow = 1

    For TempXMLSheetRow = 2 To TempXMLSheetLastRow
        If InStr(TempXMLSheet.Cells.Item(TempXMLSheetRow, 1).Value, "en-us_help") Then
            SitemapSheet.Cells.Item(SitemapSheetRow, 1).Value = TempXMLSheet.Cells.Item(TempXMLSheetRow, 1).Value
            SitemapSheetRow = SitemapSheetRow + 1
        End If
    Next TempXMLSheetRow

    While ActiveWorkbook.XmlMaps.Count > 0
        ActiveWorkbook.XmlMaps(1).Delete
    Wend

    TempXMLSheet.Columns(1).Delete
    TempXMLSheet.Columns(1).Delete
End Sub

Public Sub GetTitlesOfSelectedURLs()
    Dim URLSheet As Worksheet
    Dim XMLHttpRequest As Variant
    Dim PosLeft As Long
    Dim PosRight As Long
    Dim Pos As Long
    Dim Title As String
    Dim TempTitle As String
    Dim ArticleNumber As String
    Dim URLSheetRow As Long
    Dim UnescapedQuote As Boolean
    Dim PrependText As String


    Set URLSheet = Sheets("URLs")
    URLSheet.Activate
    If Selection Is Nothing Then Exit Sub
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set XMLHttpRequest = CreateObject("MSXML2.XMLHTTP")

    For URLSheetRow = Selection.Row To Selection.Row + Selection.Rows.Count - 1
        Pos = InStr(1, URLSheet.Cells.Item(URLSheetRow, 1), "/help/", vbTextCompare)

        If Pos > 0 Then
            Pos = Pos + 6
            ArticleNumber = Mid(URLSheet.Cells.Item(URLSheetRow, 1), Pos)
            Pos = InStr(ArticleNumber, "/")

            If Pos > 0 Then
                ArticleNumber = Mid(ArticleNumber, 1, Pos - 1)
            End If
        Else
            GoTo Here2
        End If

        PosRight = 0
        PosLeft = 0
        Title = ""
        HeadingExists = False
        XMLHttpRequest.Open "GET", "https://support.microsoft.com/app/content/api/content/help/en-us/" & ArticleNumber, False
        XMLHttpRequest.send

        While XMLHttpRequest.readyState <> 4
            DoEvents
        Wend

        'Set Title = JSON Details.Heading if it exists

        PosLeft = InStr(1, XMLHttpRequest.responseText, Chr(34) & "heading" & Chr(34) & ":", vbTextCompare)

        If PosLeft > 0 Then
            PosLeft = PosLeft + 10

            Do While Mid(XMLHttpRequest.responseText, PosLeft, 1) = " "
                PosLeft = PosLeft + 1
            Loop

            If Mid(XMLHttpRequest.responseText, PosLeft, 1) = Chr(34) Then
                PosRight = PosLeft

                Do
                    PosRight = InStr(PosRight + 1, XMLHttpRequest.responseText, Chr(34))

                    If PosRight > 0 Then
                        If Mid(XMLHttpRequest.responseText, PosRight - 1, 1) = "\" Then
                            UnescapedQuote = False
                        Else
                            Title = Mid(XMLHttpRequest.responseText, PosLeft + 1, PosRight - PosLeft - 1)
                            UnescapedQuote = True
                        End If
                    Else
                        GoTo Here1
                    End If
                Loop Until UnescapedQuote = True
            End If
        End If

Here1:
        If Title = "" Then
            'Set Title = JSON Details.Title if it exists

            PosRight = InStr(1, XMLHttpRequest.responseText, Chr(34) & "titlelower" & Chr(34) & ":", vbTextCompare)

            If PosRight > 0 Then
                PosLeft = InStrRev(XMLHttpRequest.responseText, Chr(34) & "title" & Chr(34) & ":", PosRight, vbTextCompare)

                If PosLeft > 0 And PosRight > PosLeft Then
                    PosLeft = PosLeft + 8
                    TempTitle = Mid(XMLHttpRequest.responseText, PosLeft, PosRight - PosLeft)
                    Pos = InStr(TempTitle, Chr(34))

                    If Pos > 0 Then
                        TempTitle = Mid(TempTitle, Pos + 1)
                        Pos = InStrRev(TempTitle, Chr(34))

                        If Pos > 0 Then Title = Mid(TempTitle, 1, Pos - 1)
                    End If
                End If
            End If
        End If

        Title = Replace(Title, "\" & Chr(34), Chr(34))

        If InStr(XMLHttpRequest.responseText, "&quot;FAST PUBLISH&quot") > 0 Then
            PrependText = "***FAST PUBLISH***"
            If Title <> "" Then PrependText = PrependText & " "
            Title = PrependText & Title
        End If

        URLSheet.Cells.Item(URLSheetRow, 3) = Title

Here2:
    Next URLSheetRow
End Sub

Public Sub MakeHyperlinksOfSelectedURLs()
    Dim URLSheet As Worksheet


    Set URLSheet = Sheets("URLs")
    URLSheet.Activate
    If Selection Is Nothing Then Exit Sub
    If TypeName(Selection) <> "Range" Then Exit Sub

    For URLSheetRow = Selection.Row To Selection.Row + Selection.Rows.Count - 1
        On Error Resume Next
        URLSheet.Hyperlinks.Add URLSheet.Cells.Item(URLSheetRow, 1), URLSheet.Cells.Item(URLSheetRow, 1).Value
        On Error GoTo 0
    Next URLSheetRow
End Sub