Edited at

文字列配列データをDBレコードの様にt/sqlでソートする例

More than 1 year has passed since last update.


sortrecordset.vbs


'文字列配列に含まれたキーワードで重みづけしてソートする例

'VBx VBXXX で利用可能

'文字列配列データをDBレコードの様にt/sqlでソートする例

'IN:s_array 文字列の配列

'OUT: ADODB.Recordset ( https://docs.microsoft.com/ja-jp/sql/ado/reference/ado-api/recordset-object-ado )

Function SortByRecordset(s_array)

Dim s_i, s_rs, s_len

Set s_rs = CreateObject("ADODB.Recordset")

' DATASという列と重みづけ列三つをレコードに定義

' 第2引数はvarcharを表す定数、第3引数はデータ長

Call s_rs.Fields.Append("DATAS", 200, 1024)

Call s_rs.Fields.Append("ALERTWAIT", 200, 2)

Call s_rs.Fields.Append("WARNINGWAIT", 200, 2)

Call s_rs.Fields.Append("ANTWAIT", 200, 2)

Call s_rs.Open()

For s_i = 0 To UBound(s_array)-1

Call s_rs.AddNew() ' データをレコードセットに追加していく

s_rs.Fields("DATAS").Value = s_array(s_i)

'重みの初期化

s_rs.Fields("ALERTWAIT").Value = "0"

s_rs.Fields("WARNINGWAIT").Value = "0"

s_rs.Fields("ANTWAIT").Value = "0"

if instr(s_array(s_i),"おい!") > 0 then

s_rs.Fields("ALERTWAIT").Value = "1"

end if

if instr(s_array(s_i),"まだ?") > 0 then

s_rs.Fields("WARNINGWAIT").Value = "1"

end if

if instr(s_array(s_i),"あんたが!") > 0 then

s_rs.Fields("ANTWAIT").Value = "1"

end if

Next

Call s_rs.Update()

' ソートする

s_rs.Sort = "ALERTWAIT DESC,WARNINGWAIT DESC,ANTWAIT DESC,DATAS"

SortByRecordset = s_rs.GetRows()

Call s_rs.Close()

Set s_rs = Nothing

End Function

・・・上記の利用コード例

Sql = "SELECT twitEntNO,TwitInseq,POOSTS FROM NEORELOAD..TWITTERS where inputdatetime <= '"&CheckDay&" 23:59:59' and ENDFlag<>1 order by inputdatetime"

Dim objRE

dim twittts

dim gtwittts

dim stwittts

dim crsplits

Dim myDic

Set myDic = CreateObject("Scripting.Dictionary") 'これをハッシュテーブルとして使う

Set objRE = new RegExp '正規表現処理OBJECT

objRE.IgnoreCase = True

objRE.pattern = "^.*\#NERO[ | ]([^ |^ ].+).*$"

Set Rds = SqlExecuteSub(connection, Sql) 'SqlExecuteSub は指定のDBコネクションにてSqlを実行しRecordsetオブジェクトを返す

Do Until Rds.EOF '#NERO XXXXXX の部分文字をハッシュキーにしてそのPOSTエントリーNOとINNoを連結させる

twittts= replace(Rds.Fields("POOSTS").value,chr(09),"") 'TABを消して

crsplits =Split(twittts , chr(10)) '改行でスプリットする

gtwittts = ""

stwittts = ""

For each gtwittts in crsplits '改行分文字 #NERO XXXXXX が有るか?有ればハッシュに纏めていく

if objRE.Test(gtwittts) then

stwittts= objRE.Replace(gtwittts,"$1")

if gtwittts<>stwittts then

Exit for

end if

end if

Next

if stwittts<>"" then

if myDic.Exists(stwittts) then

myDic.item(stwittts) = myDic.item(stwittts) & "," & Rds.Fields("twitEntNO").value&":"&Rds.Fields("TwitInseq").value

else

myDic.add stwittts, Rds.Fields("twitEntNO").value&":"&Rds.Fields("TwitInseq").value

end if

end if

Rds.Movenext

Loop

Set objRE = Nothing

Rds.Close

CloseDB(Conn) 'DBコネクションをCLOSE

Dim sortkeyars()

dim ari

ari=1

For Each Var In myDic

redim Preserve sortkeyars(ari)

sortkeyars(ari-1)= Var

ari = ari + 1

Next

Dim sortedkeyars,scpolor,modsn

ari=0

ocolor = "#CCCCFF"

tcolor = "#99CCFF"

cccolor= "#3366CC"

sortedkeyars = SortByRecordset(sortkeyars) '★此処★

for ari=0 to UBound(sortedkeyars,2) 'データ的に2次元配列でRecodeSetがかえるのでそのままアクセスできる

skeys = sortedkeyars(0,ari) '次元1の0にフィールド"DATAS"が、1にフィールド"ALERTWAIT"と言う様に次元1の段がフィールドの次元で、次元2が行の次元でゲット

modsn = ari mod 2

if modsn = 0 then

scpolor = ocolor

else

scpolor = tcolor

end if

・・・出力に出すなど

Next

・・・・コード利用例ここまで