データーの変化点を高速に検索する方法

質問

VB6からExcel2002へアクセスしています。

エクセルで列方向（例えばA列）へB,B,B,A,A,A,A,A,C,C,C,C,B,B,B,B...
のように格納されているデーターがあります（３万～５万行）。
このデーター列から変化点を高速に検索する方法はありませんでしょうか。
現在は、For-Nextで１セルずつ比較しながら変化点を検索、抽出しているため、非常に時間がかかっています。
Findメソッドは調べた限り、できそうにありませんでした。
高速化できる方法をご存知の方いらっしゃいましたら、よろしくお願いします。

回答No.9

mitarashi

#7,8です。
専門家では無いので、想像の域を出ませんが、VBAで下記の様なコードを実行すると、当方の遅いマシンで、50000回の倍精度浮動小数点数の計算にかかる時間は7～8msecでした。Variant型にしても、数割遅くなる程度でした。VBA恐るべし。
一方ローカルウィンドウなどで、ExcelのRange型を見ると、呆れるほど沢山の、多階層のメンバーを有する複雑なObjectである事が分かります。Excelのセルに計算をさせるときにかかる時間のほとんどはObjectとのやりとりの部分なのではないでしょうか。と、いう事で、Objectへの代入を一括で行う事で、高速化が図れるのだと想像します。
専門家の方がご覧になっていたら、補足をお願いします。
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function timeBeginPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare Function timeEndPeriod Lib "winmm.dll" (ByVal uPeriod As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub test()
Dim i As Long
Dim a As Double, b As Double, dbRet As Double

Call timeBeginPeriod(1)
Sleep 100
Debug.Print timeGetTime
For i = 1 To 50000
a = 10000.1
b = 9999.123
dbRet = Abs(a - b)
Next i
Debug.Print timeGetTime
Call timeEndPeriod(1)
End Sub

お礼

なるほど。

色々と試してみるしかなさそうですね。

ありがとうございました。

回答No.8

mitarashi

#7です。それではExcelだけでやる方法にトライ。
Sheet2のA1:B50001にデータをおきます。
1行目はA～C列に適当な見出しを付けます。例えばC1を「差」とします
A2:A50001は連番、B2:B50001は目的のデータとします。
Sheet1にフィルタオプションの条件を記します。
A1に「差」、A2に「>=100」等と条件を記します。
次のマクロを実行すると、C列の前データとの差が100以上のデータが抽出されます。実行時間はトータル1秒前後でした。範囲をまとめて処理するのがミソです。
Sub test()
Debug.Print Now
Sheets("Sheet2").Range("c3:c50001").Formula = "=abs(RC[-1]-R[-1]C[-1])"
'再計算させると悲惨な目に遭うので、式から値に置き換え
Sheets("Sheet2").Range("c3:c50001").Value = Sheets("Sheet2").Range("c3:c50001").Value
Debug.Print Now
Range("A1:C50001").AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Sheet1").Range("A1:A2"), Unique:=False
Debug.Print Now
End Sub

お礼

たびたび、ありがとうございます。

やはり「差分検出の式（いわゆる、微分といったところでしょうか）」という方法が一番高速でしょうか。

一行ずつ比較する方法が時間がかかるのは理解できるのですが、
回答いただいたような「エクセルに計算させる」方法が「極端」に高速な理由を知りたいです。

回答No.7

mitarashi

横道にずれますが、Excelのファイルで処理しないといけないんでしょうか。試しに50,000件のデータで、Access2000でやってみました。49,999レコード目に特異値を設けて試験しました。ちなみに、2.4GのCeleronで、メモリは256MB、Windows2000です。
1.Dlookupを使った重たいクエリ（1件毎に検索される？）約3分
こんなSQLです。
SELECT T_data.ID, T_data.data, Abs(DLookUp("data","T_data","ID=" & [ID]-1)-[data]) AS 差
FROM T_data
WHERE (((Abs(DLookUp("data","T_data","ID=" & [ID]-1)-[data]))>100));
2.VBA + ADOで、普通のBASICのやり方で差を求める場合、差の絶対値の算出に20秒、そのテーブルから一定以上の値を抽出するクエリは一瞬でした。
ご参考まで。

お礼

ありがとうございます。
私も、ACCESSが使えるといいと思っているのですが「諸般の事情」で、エクセルでやるしかないんです・・・

回答No.6

noname#102340

NO.3です。
セルに書き込みもしているなら、前回のコードのbをb(n,0)のように2次元配列で宣言、データ取得後に一度にセルに代入する。
objExcel.Range("B1:B" & Cstr(n)).Value = b

お礼

補足、ありがとうございます。

回答No.5

hotosys

No.2です。
よく考えたらNo.4の回答内の並べ替えの部分は不要なので、以下で試してください。

Sub sample()
'excel用定数設定
Const xlUp = -4162
Const xlNumbers = 1
Const xlCellTypeFormulas = -4123
'
Dim xl As Object
Dim lastRow As Long
Dim d As Variant
Set xl = CreateObject("Excel.application")
'xl.Visible = True '表示する場合
xl.Workbooks.Open "c:\book1.xls" 'excelファイルを開く
With xl.ActiveWorkbook.ActiveSheet '開いた時のシートに対して
'With xl.ActiveWorkbook.Sheets("Sheet1") 'シート名で指定する場合
.Columns("B").Clear '結果列クリア
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row 'A列の最終行を取得
.Range("B2:B" & lastRow).Formula = "=IF(A2<>A1,ROW(),"""")" '変化した行に行番号を表示する式を設定
.Columns("C").Clear '最終結果列クリア
.Range("B2:B" & lastRow).SpecialCells(xlCellTypeFormulas, xlNumbers).Copy .Range("C1") 'B列の計算式の数値のみC列に
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row 'C列の最終行を取得
d = xl.WorksheetFunction.Transpose(.Range("C1:C" & lastRow)) 'C列の最大行までの値を1次元配列に取り込む
xl.ActiveWorkbook.Close False 'ブックを保存せずに閉じる
xl.Quit 'excel終了
Set xl = Nothing 'excel変数破棄
'結果表示
MsgBox LBound(d) '最小添え字(1になる)
MsgBox UBound(d) '最大添え字
MsgBox d(LBound(d)) '最初の変化点
MsgBox d(UBound(d)) '最後の変化点
'もちろん途中も見れます
End With
End
End Sub

お礼

訂正、ありがとうございます。

回答No.4

hotosys

No.2です。
vb6から操作するなら以下ではどうでしょうか?
結果は配列dに入りますが、excelの関数使う関係上、d(1)-d(ubound(d))に入ります。
Sub sample()
'excel用定数設定
Const xlUp = -4162
Const xlPasteValues = -4163
Const xlAscending = 1
Const xlNo = 2
Const xlCellTypeConstants = 2
Const xlNumbers = 1
'
Dim xl As Object
Dim lastRow As Long
Dim d As Variant
Set xl = CreateObject("Excel.application")
'xl.Visible = True'表示する場合
xl.workbooks.open "c:\book1.xls" 'excelファイルを開く
With xl.ActiveWorkbook.ActiveSheet '開いた時のシートに対して
'With xl.ActiveWorkbook.Sheets("Sheet1") 'シート名で指定する場合
.Columns("B").Clear '結果列クリア
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row 'A列の最終行を取得
.Range("B2:B" & lastRow).Formula = "=IF(A2<>A1,ROW(),"""")" '変化した行に行番号を表示する式を設定
.Range("B1").Resize(lastRow, 1).Copy '計算式を値にするためにコピー
.Range("B1").Resize(lastRow, 1).PasteSpecial Paste:=xlPasteValues '値のみ貼り付け
.Range("B1").Resize(lastRow, 1).Sort Key1:=.Range("B1"), Order1:=xlAscending, Header:=xlNo '並び替え(数値を前に移動して空白を後ろに移動)
.Columns("C").Clear '最終結果列クリア
.Range("B1").Resize(lastRow, 1).SpecialCells(xlCellTypeConstants, xlNumbers).Copy .Range("C1") '最初の結果列の値のセルのみ(""セルを除く)をC列にコピー
lastRow = .Range("C" & .Rows.Count).End(xlUp).Row 'C列の最終行を取得
d = xl.WorksheetFunction.Transpose(.Range("C1:C" & lastRow)) 'C列の最大行までの値を1次元配列に取り込む
xl.ActiveWorkbook.Close False 'ブックを保存せずに閉じる
xl.quit 'excel終了
Set xl = Nothing 'excel変数破棄
'結果表示
MsgBox LBound(d) '最小添え字(1になる)
MsgBox UBound(d) '最大添え字
MsgBox d(LBound(d)) '最初の変化点
MsgBox d(UBound(d)) '最後の変化点
End With
End
End Sub

お礼

なるほど。
こういうやり方もあるんですね。
参考にさせていただきます。

ありがとうございました。

回答No.3

noname#102340

VB6で動くか分かりませんが参考までに。

Dim a(,) As Object　'シートA列のデータ。Variant型？
Dim b() As Integer '先頭位置を確保
Dim n As Integer 'データ数

n = 50
a = objExcel.Range("A1:A" & CStr(n)).Value　'objExcelは作成済みとする
ReDim b(n)
For i = 1 To n - 1
If a(i, 1) <> a(i + 1, 1) Then
b(j) = i + 1
j = j + 1
End If
Next
ReDim Preserve b(j - 1)

お礼

ありがとうございます。
試してみたのですが、
現状方法：15分
提案方法：15分
とほとんど差はありませんでした。

何か妙案があればいいのですが。

回答No.2

hotosys

こんなのではどうでしょうか？
B列に変化行を表示します。
Sub sample()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row 'A列の最終行を取得
Columns("B").Clear '結果列クリア
Range("B2:B" & Rows.Count).Formula = "=IF(A2<>A1,ROW(),"""")" '変化した行に行番号を表示する式を設定
Columns("B").Copy '計算式を値にするためにコピー
Columns("B").PasteSpecial Paste:=xlPasteValues '値のみ貼り付け
Columns("B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo '並び替え(数値を前に移動して空白を後ろに移動)
End Sub

ただB列にゴミが残るので、邪魔のようならC列を使って掃除します。
Sub sample()
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row 'A列の最終行を取得
Columns("B").Clear '結果列クリア
Range("B2:B" & Rows.Count).Formula = "=IF(A2<>A1,ROW(),"""")" '変化した行に行番号を表示する式を設定
Columns("B").Copy '計算式を値にするためにコピー
Columns("B").PasteSpecial Paste:=xlPasteValues '値のみ貼り付け
Columns("B").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo '並び替え(数値を前に移動して空白を後ろに移動)
Columns("C").Clear '最終結果列クリア
Columns("B").SpecialCells(xlCellTypeConstants, xlNumbers).Copy Range("C1") '最初の結果列の値のセルのみ(""セルを除く)をC列にコピー
Columns("B").Delete '最初の結果列を削除
End Sub

お礼

なるほど。
先にエクセル上で変化点検出を行っておくのですね。
エクセルのシート上には他にも多量のデーターが存在しますので、
WorkSheetオブジェクトかCellsオブジェクトで同じことができないか試してみます。

ありがとうございました。

回答No.1

warumx

もっと具体的に説明しないと分かる人はいないでしょう。

>B,B,B,A,A,A,A,A,C,C,C,C,B,B,B,B...

まず、A,B,C・・・等は数値ですか文字列ですか。
同じ文字は同一の内容が連続しているという意味ですか？
変化点の定義は何ですか？

お礼

＞もっと具体的に説明しないと分かる人はいないでしょう。
決めつけるのもどうかと思います。

少なくともお２方からはアドバイスをいただけましたし、
自身も「なるほど、いけるかも」と思い、試してみました。

「万人にわかる説明」という言葉があります。
たしかに、この質問はそうではなかったかも知れません。
しかし、琴線にふれて的確な回答をいただけたことも事実です。

ありがとうございました。

補足

お世話になります。

＞まず、A,B,C・・・等は数値ですか文字列ですか。
文字列もありますし、数値（整数）もあります。

＞同じ文字は同一の内容が連続しているという意味ですか？
はい、そのとおりです。不定の個数が連続しています。

＞変化点の定義は何ですか？
同じデーターが連続している最後（または次の先頭）を検出したいです。