[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAで選択範囲を検索してコピー＆ペースト』（テン）
セルＡ１から下セルへ A 1 2 3 4 5 6 7 8 9 10 と数字が並んでいます（必ずしも連続データ状にはなっていません） また、AA1セルとそれの隣のAB1セルより下には AA AB 1 12 2 3 3 47 5 21 6 2 7 1 10 32 とデータが並んでいます
この時A列の数字に一致するデータをAA列から検索して B列C列にAA列AB列のデータを記録したいのです。今回の例では A B C 1 1 12 2 2 3 3 3 47 4 5 5 21 6 6 2 7 7 1 8 9 10 10 32
こういった具合にVBAにより当てはめていきたいのです。 どうかよろしくお願いいたします。
数式をＶＢＡで設定しただけですけど・・・・。
Sub test()
Dim ra As Range
Dim frm As String
Dim raa As Range
Dim raaab As Range
Set ra = Range("a1", Cells(Rows.Count, "a").End(xlUp))
Set raa = Range("aa1", Cells(Rows.Count, "aa").End(xlUp))
Set raaab = raa.Resize(, 2)
frm = "=IF(ISERROR(MATCH(" & ra.Address & "," & raa.Address & ",0)),"""",INDEX(" & _
raaab.Address & ",MATCH(" & ra.Address & "," & raa.Address & ",0),COLUMN()-1))"
With ra.Offset(0, 1).Resize(, 2)
.FormulaArray = frm
.Value = .Value
End With
End Sub
ichinose
ichinoseさん、返信ありがとうございます。テンです。 あれから一晩考えてみたところ、次の記述で自己解決できたのかな？と思いました。 参考までに載せてみます。 Sub test() i = Selection(1).Row j = Selection(1).Column k = Selection(Selection.Count).Row
For m = i To k For y = 1 To 30 If Cells(y, 1) = Cells(m, j) Then
Cells(y, 2) = Cells(m, j)
Cells(y, 2 + 1) = Cells(m, j + 1)
End If Next y Next m End Sub
すばやい回答をしていただいたichinoseさん有難うございました！
解決されたようですが、せっかくの題材なので、もうちょっと掘り下げて見ました。 私の前回の投稿は、取りあえず取り消し・・（動作はするはずですが・・・）。 検索手法として、掘り下げてみましょう。 >次の記述で自己解決できたのかな？と思いました。 はい、細かいことはさておき、逐次検索のロジックは出来ていますね！！ Ａ列のデータ件数が30件程度で AA列のデータ件数の数10件程度なら、どのような アルゴリズムでもそれ程のストレスは感じずに処理はされます。
が、Ａ列データ件数が5000件で ＡＡ列のデータ件数も2000件程ある場合で検証してみます。
新規ブックの標準モジュール（Module1）に
'====================================================================
Sub sample_data()
With Range("a1:a5000")
.Formula = "=row()*3-1"
.Value = .Value
End With
With Range("aa1:ab2000")
.Formula = Array("=row()*2-1", "=int(rand()*10000)+1")
.Value = .Value
End With
End Sub
適当なシートをアクティブにして、上記sample_dataを実行してみてください。 Ａ列、ＡＡ列及び、ＡＢ列にサンプルデータが作成されます。 このデータで色々なコードで処理速度を検証してみました。 尚、今回はExcelの関数等は使わないことにしました。これを使えば、結果は違ってくるでしょうが・・。
まず、テンさんのコード。ちょっとだけ修正して・・・。 標準モジュールに（Module2）、
'=====================================================================
Sub test()
Dim st As Double
Dim i As Long
Dim j As Long
Dim k As Long
Dim y As Long
Dim m As Long
Dim l As Long
Range("b:c").ClearContents
Application.ScreenUpdating = False
st = [now()]
l = Range("a" & Rows.Count).End(xlUp).Row
i = Range("aa1", Cells(Rows.Count, "aa").End(xlUp)).Row
j = Range("aa1", Cells(Rows.Count, "aa").End(xlUp)).Column
k = Range("aa1", Cells(Rows.Count, "aa").End(xlUp)).Rows.Count
st = [now()]
For m = i To k
For y = 1 To l
If Cells(y, 1) = Cells(m, j) Then
Cells(y, 2) = Cells(m, j)
Cells(y, 2 + 1) = Cells(m, j + 1)
End If
Next y
Next m
Application.ScreenUpdating = True
MsgBox Application.Text([now()] - st, "hh:mm:ss.00")
End Sub
上記のtestを実行すると、私の環境で約9分程度かかりました。
これは、検索ロジックが逐次検索（AA1のデータがＡ列のどこにあるかを検索するのに 1行目が順々に照らし合わせていく方法）を使っている事とFor〜Next内でCellsを使っている事が 時間のかかっている大きな要因になっています。
これを逐次検索の手法は変えずにデータのやり取りを内部変数を使って行なうと・・・、
標準モジュール（Module3）に
'========================================================================
Sub test2()
Dim st As Double
Dim ra As Variant
Dim raaab As Variant
Dim aaRW As Long
Dim aRW As Long
Dim rbc() As Variant
Range("b:c").ClearContents
st = [now()]
ra = Range("a1", Cells(Rows.Count, "a").End(xlUp)).Value
ReDim rbc(1 To UBound(ra), 1 To 2)
raaab = Range("aa1", Cells(Rows.Count, "aa").End(xlUp)).Resize(, 2).Value
For aaRW = LBound(raaab) To UBound(raaab)
For aRW = LBound(ra) To UBound(ra)
If ra(aRW, 1) = raaab(aaRW, 1) Then
rbc(aRW, 1) = raaab(aaRW, 1)
rbc(aRW, 2) = raaab(aaRW, 2)
End If
Next
Next
Range("b1:c" & UBound(rbc)).Value = rbc()
MsgBox Application.Text([now()] - st, "hh:mm:ss.00")
End Sub
とすると、8秒まで処理時間が縮まりました。 逐次検索の手法でもうまく内部変数を使えば、まあまあの処理時間まで短縮できますね！！
これを二分探索のアルゴリズムを使って処理すると・・・・、
標準モジュール（Module4）に
'===================================================================
Sub Binary_Search()
Dim st As Double
Dim ra As Range
Dim ans As Long
Dim raaab As Variant
Dim aaRW As Long
Dim aRW As Long
Dim rbc() As Variant
Range("b:c").ClearContents
st = [now()]
Set ra = Range("a1", Cells(Rows.Count, "a").End(xlUp))
ReDim rbc(1 To ra.Rows.Count, 1 To 2)
raaab = Range("aa1", Cells(Rows.Count, "aa").End(xlUp)).Resize(, 2).Value
Call open_tbl(ra, 1, 0)
For aaRW = LBound(raaab) To UBound(raaab)
If gets_tbl(raaab(aaRW, 1), ans) = 0 Then
rbc(ans, 1) = raaab(aaRW, 1)
rbc(ans, 2) = raaab(aaRW, 2)
End If
Next
Range("b1:c" & UBound(rbc)).Value = rbc()
Call close_tbl
MsgBox Application.Text([now()] - st, "hh:mm:ss.00")
End Sub
別の標準モジュール（Module5）に二分探索を行なうプロシジャー群
'==================================================================================
Option Explicit
Private r_array() 'セル範囲をこの配列にセット
Private r_col As Long '配列の検索キー列番号
Private r_type As Long '検索列の比較の型
' 0:数値
' 1以上:文字列右寄せ比較の場合、数値は、最大文字数
Private wk1, wk2 'ワーク変数
'==================================================================================
Sub open_tbl(rng As Range, key As Long, ktype As Long)
' セル範囲を配列にセットし、内部変数を初期化する
'input : rng --検索対象セル範囲
' key---配列内の検索キーとして、列番号
' ktype--比較の型と最大文字数
Call close_tbl
r_array() = rng.Value
r_col = key
r_type = ktype
If ktype > 0 Then
wk1 = Space$(ktype)
wk2 = Space$(ktype)
End If
End Sub
'==================================================================================
Function gets_tbl(f_val As Variant, ans As Long) As Long
'r_aaray()配列のr_colで指定された列をf_valの値で検索しその位置を返す
'input : f_val-----検索値
'output: gets_tbl----0:検索できた 1:検索値はみつからない
' ans-----検索された配列行位置
Dim r_st As Long
Dim r_ed As Long
Dim r_bin As Long
r_st = LBound(r_array(), 1)
r_ed = UBound(r_array(), 1)
gets_tbl = 1
Do Until r_st > r_ed
r_bin = Int((r_st + r_ed) / 2)
If r_type > 0 Then
RSet wk1 = f_val
RSet wk2 = r_array(r_bin, r_col)
Else
wk1 = f_val
wk2 = r_array(r_bin, r_col)
End If
If wk1 = wk2 Then
ans = r_bin
gets_tbl = 0
Exit Do
ElseIf wk1 < wk2 Then
r_ed = r_bin - 1
Else
r_st = r_bin + 1
End If
Loop
End Function
'==================================================================================
Sub close_tbl()
Erase r_array()
End Sub
これでBinary_Searchを実行してみてください。私の環境で0.05秒でした。 二分探索については、詳しいアルゴリズムは、検索すれば見つかりますから、調べてみてください。
Dictionaryというオブジェクトがあります。中のアルゴリズムを知っているわけではないので、 これをハッシュ検索と呼ぶには、疑問もありますが、ハッシュと呼んでいる人もいるようなので Dictionaryを使って、ハッシュ検索で試してみると・・・、
標準モジュール（Module6）に
'==============================================================================
Sub ハッシュ検索()
Dim dic As Object
Dim aaRW As Long
Dim st As Double
Dim ra As Range
Dim frm As String
Dim rarray As Variant
Dim raaab As Variant
Range("b:c").ClearContents
st = [now()]
Set dic = CreateObject("scripting.dictionary")
For Each ra In Range("a1", Cells(Rows.Count, "a").End(xlUp))
dic.Add CStr(ra.Value), Array("", "")
Next
raaab = Range("aa1", Cells(Rows.Count, "aa").End(xlUp)).Resize(, 2).Value
For aaRW = LBound(raaab) To UBound(raaab)
If dic.Exists(CStr(raaab(aaRW, 1))) Then
rarray = dic.Item(CStr(raaab(aaRW, 1)))
rarray(0) = raaab(aaRW, 1)
rarray(1) = raaab(aaRW, 2)
dic.Item(CStr(raaab(aaRW, 1))) = rarray
End If
Next
Range("a1", Cells(Rows.Count, "a").End(xlUp)).Offset(0, 1).Resize(, 2).Value = _
Application.Transpose(Application.Transpose(dic.Items))
Set dic = Nothing
Set ra = Nothing
MsgBox Application.Text([now()] - st, "hh:mm:ss.00")
End Sub
上記の ハッシュ検索 を実行すると、私の環境で 0.64秒でした。
二分探索の場合、Ａ列のデータが整列していなければならないという制約がありますが、 ハッシュ検索の場合は、その制約がないので、処理時間の差だけでは判断できません。 尚、ハッシュ検索についてもネットの検索で意味は理解できると思います。
逐次検索、二分探索、ハッシュ検索(?)と記述しましたが、一長一短はありますから、 データ量によって、使い分けるのが良いと思います。 Officeを使っていれば、このような検索も別の方法がいくらでもあるので、 今回提示したようなコードを記述することは殆どないのですが、 プログラマー1年目で習いますから、上記の三つの手法ぐらいは、覚えておいても 損はないと思いますよ！！
時間があったら試してみてください。
ichinose
コメントありがとうございます。 ichinoseさん、レベルが高過ぎて古文書にしか見えません^^; しかし私のロジックで９分かかるところが最速では0.05秒ですか。。。 素人に産毛が生えたような私ですがかなり興味を惹かれました！ コメント何度も読み直して、これをきっかけにプログラムの理解を少しでも深めてみます。 ichinoseさん丁寧な解説コメントどうもありがとうございました！！！
テン
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.