Sub test()
Dim html As Object, D As Object, W As Object
Dim arrData(1 To 1000, 1 To 20)
Dim reg As Object
Dim n As Long, file As String
'file网页文件来源www.okooo.com
Sheet1.Cells.Clear
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False '单选择
.Filters.Clear '清除文件过滤器
'.Filters.Add "html Files", "*.htm;*.html"
.Filters.Add "All Files", "*.*" '设置两个文件过滤器
If .Show = -1 Then
'FileDialog 对象的 Show 方法显示对话框,并且返回 -1(如果您按 OK)和 0(如果您按 Cancel)。
file = .SelectedItems(1)
'MsgBox "您选择的文件是:" & .SelectedItems(1), vbOKOnly + vbInformation, "Aisa Handicap"
End If
End With
Set html = CreateObject("MSXML2.XMLHTTP")
html.Open "GET", file, False
html.setRequestHeader "Accept-Language", "zh-cn"
html.send: strhtml = html.responsebody
strhtml = StrConv(strhtml, vbUnicode)
Set html2 = CreateObject("htmlfile")
html2.body.innerhtml = strhtml
Set html_temp1 = html2.getElementById("data_main_content") '根据ID查找table
html2.write html_temp1.innerhtml
i = 0
For Each TR In html2.all.tags("table")(0).Rows '
i = i + 1
j = 0
For Each TD In TR.Cells
j = j + 1
Cells(i, j) = TD.innerText
Debug.Print arrData(i, j)
Next
Next
With CreateObject("VBscript.regexp")
.Global = ture
.Pattern = "bright\sfeedbackObj.{24}" '取时间
For n = 0 To 100 Step 1
For Each D In .Execute(strhtml)
'Debug.Print D
Cells(n + 1, 15) = Split(Split(D, "bright feedbackObj"" title=""开盘时间: 赛前")(1), """") '去掉两种字符串
strhtml = .Replace(strhtml, "")
Next
Next
End With
'排序,先把时分时间转成分钟数
For n = 1 To 100 Step 1
If Cells(n, 15) <> "" Then
Cells(n, 16) = 60 * CLng(Split(Cells(n, 15), "时")(0)) + Split(Split(Cells(n, 15), "时")(1), "分")(0)
End If
Next
'hong
ActiveWindow.SmallScroll Down:=-6
Columns("P:P").Select
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("sheet1").Sort.SortFields.Add Key:=Range("P:P") _
, SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("sheet1").Sort
.SetRange Range("A1:Q100")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWindow.SmallScroll Down:=-3
With CreateObject("VBscript.regexp")
.Global = ture
.Pattern = "<title.*</title>" '取标题
For n = 0 To 100 Step 1
For Each D In .Execute(strhtml)
Cells(n + 1, 17) = Split(Split(D, "<title>")(1), "</title>")(0) '添加标题
'MsgBox Cells(n + 1, 17)
strhtml = .Replace(strhtml, "")
Next
Next
End With
'添加颜色
Columns("C:C").Select
Selection.FormatConditions.AddColorScale ColorScaleType:=3
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
xlConditionValuePercentile
Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 8711167
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
Columns("E:E").Select
Selection.FormatConditions.AddColorScale ColorScaleType:=3
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).ColorScaleCriteria(1).Type = _
xlConditionValueLowestValue
With Selection.FormatConditions(1).ColorScaleCriteria(1).FormatColor
.Color = 8109667
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(2).Type = _
xlConditionValuePercentile
Selection.FormatConditions(1).ColorScaleCriteria(2).Value = 50
With Selection.FormatConditions(1).ColorScaleCriteria(2).FormatColor
.Color = 8711167
.TintAndShade = 0
End With
Selection.FormatConditions(1).ColorScaleCriteria(3).Type = _
xlConditionValueHighestValue
With Selection.FormatConditions(1).ColorScaleCriteria(3).FormatColor
.Color = 7039480
.TintAndShade = 0
End With
Columns("A:Q").Select
With Selection.Font
.Name = "宋体"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
Cells(1, 17).Select
End Sub
查询足球亚盘 最早开盘时间
最新推荐文章于 2024-06-04 16:32:09 发布