以下の修正でうまくいきました。

Private Function GetHtml(Url)
　Dim buf , string
　SamAgent = "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)"
　On Error Resume Next
　'Set xh = CreateObject("MSXML2.ServerXMLHTTP")　　　←コメントアウト
　Set xh = CreateObject("WinHttp.WinHttpRequest.5.1")　　←追加
　xh.Option(9) = 2560　　　　　　　　　　　　　　　　　　←追加
　If Err <> 0 Then