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'>007</td><td class='red big'>78018</td>
.Pattern = "(>)(\d{3})(?:</td><td class='red big'>)(\d{5})(?:</td>)"
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

  

20170728xlVba SSC_LastTwoDays的更多相关文章

  1. 20170728xlVba还是这个混蛋

    Public Sub Main22() If Now() >= #1/1/2018# Then Exit Sub Dim strText As String Dim Reg As Object, ...

  2. 20170728xlVba SSC_TODAY

    Public Sub SSC_TODAY() Dim strText As String Dim Reg As Object, Mh As Object, OneMh As Object Dim i ...

  3. 20170728xlVba简单的匹配

    Sub MatchData() Dim i As Long, EndRow As Long, Key As String Dim Rng As Range Dim Dic As Object Set ...

  4. 20170728xlVBA改转置一例

    Sub 导出() Dim Sht As Worksheet, ShtName As String Dim NextRow As Long, NextRow2 As Long Dim iRow As L ...

随机推荐

  1. 【Python】Python 网页爬虫 & 文本处理 & 科学计算 & 机器学习 & 数据挖掘兵器谱

    本文转载自:https://www.cnblogs.com/colipso/p/4284510.html 好文 mark http://www.52nlp.cn/python-%E7%BD%91%E9 ...

  2. ubuntu14.04无法安装Curl,需要先升级sudo apt-get update

    ubuntu14.04无法安装Curl,需要先升级sudo apt-get updatesudo apt-get updatesudo apt-get install curl------------ ...

  3. MySQL数据库----安装

    一.基础部分 1.数据库是什么 之前所学,数据要永久保存,比如用户注册的用户信息,都是保存于文件中,而文件只能存在于某一台机器上. 如果我们不考虑从文件中读取数据的效率问题,并且假设我们的程序所有的组 ...

  4. YAML配置文件

    最近,研究jeeweb这个框架,发现新版本中的配置文件都是用的.yml为后缀的文件,打开一看,和以前的xml和properties语法有很大区别,因此仔细研究一下. 简介: YAML是(YAML Ai ...

  5. centos下gitlab私服完整安装部署(nginx+MySQL+redis+gitlab-ce+gitlab-shell+)

    系统环境cat /etc/redhat-release CentOS release 6.8 (Final) nginx -vnginx version: nginx/1.9.15 redis-cli ...

  6. Nodejs 实现 WebSocket 太容易了吧!!

    我们基于express和socket.io开发,首先我们需要安装以下包 npm install --save express npm install --save socket.io 服务器端代码: ...

  7. Bootloader之uBoot简介

    本文转载自:http://blog.ednchina.com/hhuwxf/1915416/message.aspx 一.Bootloader的引入 从前面的硬件实验可以知道,系统上电之后,需要一段程 ...

  8. dp暑假专题 训练记录

    A 回文串的最小划分 题意:给出长度不超过1000的字符串,把它分割成若干个回文字串,求能分成的最少字串数. #include <iostream> #include <cstdio ...

  9. 初始 DQN 程序 所遇到的问题

    初始 DQN 程序 所遇到的问题 最近在看 DQN,但是想试试别人放出来的 code,但是发现,额,各种问题,在此记录,以备不时之需! 问题1. wangxiao@GTX980:~/Documents ...

  10. IntelliJ IDEA问题总结

    在使用Idea的过程中,会遇到各种各样的问题,下面我将在这里持续总结: 1.Unable to import maven project: See logs for details 在遇到这个问题时, ...