Public Sub SSC_TODAY()
Dim strText As String
Dim Reg As Object, Mh As Object, OneMh As Object
Dim i As Long
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "http://cp.360.cn/ssccq?agent=700007", False
.Send
strText = .responsetext
End With
Set Reg = CreateObject("Vbscript.Regexp")
With Reg
.MultiLine = True
.Global = True
.Ignorecase = False
'20170728084">084</span><em class="code">77563</em>
.Pattern = "(\d{11})(?:.>)(\d{3})(?:</span><em class=""code"">)(\d{5})(?:</em>)"
Set Mh = .Execute(strText)
End With
With Sheets(1)
.Cells.ClearContents
.Range("A1:N1").Value = Array("大期号", "小期号", "万", "千", "百", "十", "个", "后三", "组01", "组23", "组45", "组67", "组89", "预测")
Index = 1
For Each OneMh In Mh
Index = Index + 1
.Cells(Index, 1).Value = "'" & OneMh.submatches(0)
.Cells(Index, 2).Value = OneMh.submatches(1)
op = OneMh.submatches(2)
For j = 1 To Len(op)
.Cells(Index, j + 2).Value = Mid(op, j, 1)
Next j
.Cells(Index, 8).Value = "'" & Right(op, 3)
Next OneMh
Sort2003 .UsedRange, 2
For i = 2 To Index
s = .Cells(i, 8).Text
gua = 0
For j = 9 To 13
keys = Replace(.Cells(1, j).Text, "组", "")
key1 = Left(keys, 1)
key2 = Right(keys, 1)
'Debug.Print s; " "; keys
If InStr(1, s, key1) = 0 And InStr(1, s, key2) = 0 Then
.Cells(i, j).Value = "中"
Else
.Cells(i, j).Value = "挂"
gua = gua + 1
End If
Next j
If gua >= 3 Then
.Cells(i, 14).Value = "挂"
Else
.Cells(i, 14).Value = "中"
End If
Next i
With .UsedRange
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
End With
SetBorders .UsedRange
Dim uRng As Range
Dim OneCell As Range
For Each OneCell In .UsedRange.Cells
If OneCell.Text = "中" Then
If uRng Is Nothing Then
Set uRng = OneCell
Else
Set uRng = Union(uRng, OneCell)
End If
End If
Next OneCell
FillRed uRng
End With
Set Reg = Nothing
Set Mh = Nothing
Set uRng = Nothing
End Sub
Sub Sort2003(ByVal RngWithTitle As Range, Optional SortColumnNo As Long = 1)
With RngWithTitle
.Sort key1:=RngWithTitle.Cells(1, SortColumnNo), Order1:=xlAscending, Header:=xlYes, _
MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
End With
End Sub
Sub SetBorders(ByVal Rng As Range)
With Rng.Borders
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.Weight = xlThin
End With
End Sub
Sub FillRed(ByVal Rng As Range)
With Rng.Font
.ColorIndex = 3
.Bold = True
End With
End Sub