Excel VBA批量获取重定向URL网址

在做SEO或者扒数据时，有时需要批量获得一些URL的重定向地址，单个打开麻烦，将已经做重定向的URL粘贴到Excel文件Sheet2的A列，运行下列代码即可。

Sub UrlRedirect()
    Dim XmlHttp As Object
    On Error Resume Next
   
    With CreateObject("WinHttp.WinHttpRequest.5.1")
        For Each c In Selection  '选中sheet2中第一列的多个目标单元
            .Open "GET", c.Value, False
            .option(6) = False '是否允许Redirect
            .settimeouts 0, 0, 0, 2000  '第一个0是解析时间，第二个0是连接服务器的时间，第三个0是向服务器发送请求的时间，第四个是等待数据返回的时间。单位是毫秒。
            .Send
            c.Offset(0, 1).Value = .GetResponseHeader("Location") '最终的链接
        Next c
    End With
End Sub