Option Explicit
Dim wb
Sub Macro1()
Dim winhttp, url, t, arr, i, j, arr1, n, d, dw
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
url = "http://www.okooo.com/jingcai/"
With winhttp
Application.StatusBar = "正在連接..."
.Open "GET", url, False
.setRequestHeader "Connection", "Keep-Alive"
.Send
t = BytesToBstr(.ResponseBody, "GB2312")
'    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")       '調(diào)試用，數(shù)據(jù)放入剪貼板
'        .SetText t
'        .PutInClipboard
'    End With
End With
Set wb = Workbooks.Add
arr1 = Split(t, "<div class=""touzhu"">")
For j = 2 To UBound(arr1)
d = Date + j - 2
t = arr1(j)
arr = Split(t, "'歐']);""")
For i = 1 To UBound(arr)
On Error Resume Next
url = "http://www.okooo.com" & Split(Split(arr(i), "href=""")(1), """")(0)
dw = Split(Split(Split(arr(i), "zhum fff hui_colo")(1), "=""")(1), """>")(0) & "VS" & Split(Split(Split(arr(i), "zhum fff hui_colo")(2), "=""")(1), """>")(0)
Set wb = ActiveWorkbook
Call Macro2(url, d, dw)
Next
Next
wb.SaveAs ThisWorkbook.Path & "\" & Application.Text(d, "mm-dd") & ".xls"
wb.Close
Set winhttp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True

End Sub
Function BytesToBstr(strBody, CodeBase)                        '使用Adodb.Stream對(duì)象提取字符串
Dim objStream
On Error Resume Next
Set objStream = CreateObject("Adodb.Stream")
With objStream
.Type = 1                                                              '二進(jìn)制
.Mode = 3                                                             '讀寫
.Open
.Write strBody                                                       '二進(jìn)制數(shù)組寫入Adodb.Stream對(duì)象內(nèi)部
.Position = 0                                                         '位置起始為0
.Type = 2                                                             '字符串
.Charset = CodeBase                                            '數(shù)據(jù)的編碼格式
BytesToBstr = .ReadText                                       '得到字符串
End With
objStream.Close
Set objStream = Nothing
If Err.Number <> 0 Then BytesToBstr = ""
On Error GoTo 0
End Function
Sub Macro2(url, d, dw)
Dim winhttp, oDoc, t, i, j, r, n, p, PostData, state, page, arr2, arr, wb, sht, url1, wb1
Application.ScreenUpdating = False
Application.DisplayStatusBar = True
Set sht = ActiveWorkbook.Sheets.Add(Sheets("Sheet1"))
sht.Name = dw
sht.Cells.Clear
arr = Array("序號(hào)", "公司名", "主", "客", "平", "主", "平", "客")
sht.Range("a1").Resize(1, 8) = arr
Set winhttp = CreateObject("Microsoft.XMLHTTP")
Set oDoc = CreateObject("htmlfile")
With winhttp
On Error Resume Next
For p = 0 To 12
url1 = url & "ajax/?page=" & p & "&companytype=BaijiaBooks&type=1"
Application.StatusBar = "正在連接..."
.Open "GET", url1, False
.setRequestHeader "Connection", "Keep-Alive"
.Send
t = "<table>" & .responsetext & "</table>"

oDoc.body.innerhtml = t
Set r = oDoc.all.tags("table")(0).Rows
ReDim arr2(0 To r.Length, 0 To 7)
For i = 0 To r.Length - 1
For j = 0 To r(i).Cells.Length - 9
arr2(i, j) = r(i).Cells(j).innertext
Next j
Next i
sht.Range("a" & sht.[a65536].End(xlUp).Row + 1).Resize(UBound(arr2), 8) = arr2
Erase arr2
Next
sht.Cells.Replace What:="↑ ", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
sht.Cells.Replace What:="↓ ", Replacement:="", LookAt:=xlPart, SearchOrder _
:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
n = sht.[a65536].End(xlUp).Row
End With
Set sht = Nothing
Set oDoc = Nothing
Set winhttp = Nothing
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub