请帮忙修改一下自动导入网页部分数据的代码（赠送财富值2000）

zhjiwenc

我把宏代码贴贴出来，也是网上的，原来一直好用，昨天开始就不行了，沪深的数据采集不了了，跪求解决方案！先谢谢了
Sub downloadSohuData()
    Dim strQuery As String
    Dim txtContent As String
    Dim httpreq As XMLHTTP30
    Dim arrTemp() As Variant
    Dim arrT As Variant
    Dim arrT1 As Variant
    Dim strCode As String
    Dim i As Integer
    Dim j As Integer
    Dim dDate As Date
    Dim iFound
    Dim iRow As Integer
    Dim strTemp As String
   
    Application.ScreenUpdating = False
   
    If Cells(2, 1) = "" Then Exit Sub
    iRow = Range("A1").End(xlDown).Row
    Set httpreq = New XMLHTTP30
    For j = 2 To iRow
        Application.StatusBar = Format((j - 1) / (iRow - 1) * 100, "0.00") & "% finished..."
        strCode = Cells(j, 1)
        If Len(strCode) = 4 Then
            strQuery = "http://hqk.stock.sohu.com/hk/" & Right(strCode, 3) & "/hk_0" & strCode & "-1.html"
        Else
            strQuery = "http://hq.stock.sohu.com/cn/" & Right(strCode, 3) & "/cn_" & strCode & "-1.html"
        End If
        
        httpreq.Open "GET", strQuery, False
        httpreq.setRequestHeader "Content-Type", "text/html"
        httpreq.send
        
        If httpreq.Status = 200 Then
            txtContent = httpreq.responseText
            txtContent = Mid(txtContent, InStr(1, txtContent, "</script>") + 9)
            txtContent = Left(txtContent, InStr(1, txtContent, "</script>"))
            
            arrT = Split(txtContent, """,""")
            If UBound(arrT) = 0 Then
                arrT = Split(txtContent, "','")
            End If
            Cells(j, 2) = arrT(1)
            Cells(j, 3) = arrT(2)
            strTemp = arrT(UBound(arrT))
            If Left(strTemp, 1) <> """" Or Left(strTemp, 1) <> "'" Then
                If InStr(1, strTemp, """") = 0 Then
                    Cells(j, 4) = Left(strTemp, InStr(1, strTemp, "'") - 1)
                Else
                    Cells(j, 4) = Left(strTemp, InStr(1, strTemp, """") - 1)
                End If
            End If
        Else
            reportErr httpreq.Status
        End If
    Next j
    httpreq.abort
    Application.StatusBar = False
    Application.ScreenUpdating = True
    Set httpreq = Nothing
End Sub

Sub reportErr(lStatus As Integer)
        Select Case lStatus
            Case 400
                MsgBox "Bad Request", vbCritical, "连接错误"
            Case 401
                MsgBox "Unauthorized", vbCritical, "连接错误"
            Case 402
                MsgBox "Payment Required", vbCritical, "连接错误"
            Case 403
                MsgBox "Forbidden", vbCritical, "连接错误"
            Case 404
                MsgBox "Not Found", vbCritical, "连接错误"
            Case 407
                MsgBox "Proxy Authentication Required", vbCritical, "连接错误"
            Case 408
                MsgBox "Request Timeout", vbCritical, "连接错误"
            Case 503
                MsgBox "Service Unavailable", vbCritical, "连接错误"
            Case Else
                MsgBox "Can not reach by other reason", vbCritical, "连接错误"
        End Select
End Sub

zhjiwenc

                急求帮助

songroad

非常有用，留名细看，感谢各位高手。

wjkkk

留名细看，感谢各位高手。

no110119120

到了这里,才知道excel这么牛,初学者膜拜中.

lubbyming

新手学习了，留个记号

deweyfbi

MARK一下，以后需要查找·

谨慎生存

新手，学习中，期望楼主指导一下学习的路径，比如需要看那些书，从哪些方面着手等

wendy215

非常好用，谢谢

fqqwan

winland 发表于 2009-6-13 18:19
做了一个比较完整的版本。这个导出的数据是沪深A股的全部数据。
财富就不需要了，一句话，助人为快乐之本 ...

太厉害了 版主 谢谢你 创业板的能否也做一个啊？