Help us understand the problem. What is going on with this article?

文字列配列データを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

・・・・コード利用例ここまで
engbJapan
今年、60年超えの古民家を事務所として 猫に監察されつつオカメインコと共に開業中です。
http://goodwayatnew.jp/
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away