20170728xlVba SSC_TODAY

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