20170728xlVba SSC_LastTwoDays

Public Sub SSCLastTwoDays()

    Dim strText As String
    Dim Reg As Object, Mh As Object, OneMh As Object
    Dim i As Long

    Set Reg = CreateObject("Vbscript.Regexp")
    With Reg
        .MultiLine = True
        .Global = True
        .Ignorecase = False
        'class='gray'>00778018
        .Pattern = "(>)(\d{3})(?:)(\d{5})(?:)"
    End With



    Dim Today As String, Yesterday As String


    Yesterday = Format(DateAdd("d", -1, Now()), "yyyy-mm-dd")
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://chart.cp.360.cn/kaijiang/kaijiang?lotId=255401&spanType=2&span=" & Yesterday & "_" & Yesterday, False
        .Send
        strText = .responsetext
    End With
    Set Mh = Reg.Execute(strText)

    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 = "'" & Format(Yesterday, "yyyymmdd") & OneMh.submatches(1)
            .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
    End With

    Today = Format(Now, "yyyy-mm-dd")
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://chart.cp.360.cn/kaijiang/kaijiang?lotId=255401&spanType=2&span=" & Today & "_" & Today, False
        .Send
        strText = .responsetext
    End With

    Set Mh = Reg.Execute(strText)
    With Sheets(1)
        For Each OneMh In Mh
            Index = Index + 1
            .Cells(Index, 1).Value = "'" & Format(Today, "yyyymmdd") & OneMh.submatches(1)
            .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
    End With


    With Sheets(1)
        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

　　

转载于:https://www.cnblogs.com/nextseven/p/7252857.html