Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2428 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

▼

【67986】dictionaryオブジェクトについて MIMI 11/1/21(金) 16:28

【67987】Re:dictionaryオブジェクトについて Yuki 11/1/21(金) 16:52

【67992】Re:dictionaryオブジェクトについて MIMI 11/1/24(月) 11:11

【68017】Re:dictionaryオブジェクトについて Yuki 11/1/25(火) 14:46

【68089】Re:dictionaryオブジェクトについて MIMI 11/1/31(月) 16:39

【68090】Re:dictionaryオブジェクトについて Yuki 11/1/31(月) 17:32

【67988】Re:dictionaryオブジェクトについて ｍｏｍｏ 11/1/21(金) 19:27

【67993】Re:dictionaryオブジェクトについて MIMI 11/1/24(月) 11:21

【67999】Re:dictionaryオブジェクトについて MIMI 11/1/24(月) 16:51

【68001】Re:dictionaryオブジェクトについて ｍｏｍｏ 11/1/24(月) 17:24

【68021】Re:dictionaryオブジェクトについて MIMI 11/1/25(火) 16:31

【67991】Re:dictionaryオブジェクトについて 山猿 11/1/23(日) 9:06

【67994】Re:dictionaryオブジェクトについて MIMI 11/1/24(月) 11:23

【68024】Re:dictionaryオブジェクトについて 山猿 11/1/25(火) 20:20


	【67986】dictionaryオブジェクトについて

MIMI - 11/1/21(金) 16:28 -


	引用なし

	パスワード

exists　で、アイテムの存在の有無を確認するときに、
LIKE演算子は使えないのでしょうか？
あいまい検索的な感じにアイテムをヒットさせたいのですが
どうもうまくいかなくて困ってます

今のコードは下記の通りです

Ａ列の2行目から最終行までのデータを、
dictionaryオブジェクトの中に格納します

ここで、A列のデータというのが、*や？を含んだものです

シート1
Ａ列
*AAA?1*BBB?1*CCC?1
*EEE?2*EWRE?7*QQQQ?2
*DDD?4*EEE?1*SSS?7

このようなデータが3000件ほどあります

シート2
Ａ列
DDD-4|EEE-1|SSS-7
EEEq2|EWRE-7|QQQQ-2

など、*や？が入っていないデータがあります

それを今度は、
シート2のリストを調べていき、
dictionaryオブジェクトの中に存在しているかを確認し
存在していれば、Itemを入れるといった感じにしたいのですが、
existsのときに、Like演算子がうまく使えないのですが、使うことはできないのでしょうか？

たとえば、シート2内の
DDD-4|EEE-1|SSS-7　は　*DDD?4*EEE?1*SSS?7　である
という認識をさせたいのです

Set MyD = CreateObject("scripting.dictionary")

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
　　If Not MyD.exists(Range("A" & i).Value) Then
　　　 MyD.Add Range("A" & i).Value, Range("B" & i).Value
　　End If
Next i

Sheets("シート2").Activate
　For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
　　If MyD.exists(Range("A" & i).Value) Then
　　　 ↑ココで、指定文字を含むものがあるか？どうか？を判断させたいです

　　　 Range("B" & i).Value=MyD.Item(Range("A" & i).Value)
　　End If
Next i

どうか、ご教授願います


	【67987】Re:dictionaryオブジェクトについて

Yuki - 11/1/21(金) 16:52 -


	引用なし

	パスワード

▼MIMI さん：
　　If MyD.exists(Range("A" & i).Value) Then
　　　 '↑ココで、指定文字を含むものがあるか？どうか？を判断させたいです
　　　 ' もう一度聞く
　　　　If MyD.Item(Range("A" & i).Value) Like "指定文字" Then
　　　　　 Range("B" & i).Value = MyD.Item(Range("A" & i).Value)
　　　　End If
　　End If
こんな風でどうでしょう。
検証していないので間違っていたら失礼


	【67988】Re:dictionaryオブジェクトについて

ｍｏｍｏ - 11/1/21(金) 19:27 -


	引用なし

	パスワード

▼MIMI さん：正規表現でSubMatchesを使ってみるとかはどうでしょうね？（にしても長いPattern・・・・）　Option Explicit 　Sub 正規表現パターン逆引() 　Dim ans() As Variant, tbl1 As Variant, tbl2 As Variant 　Dim i As Long, j As Long 　Dim myPt As String 　tbl1 = Worksheets("Sheet1").Range("A1").CurrentRegion.Value 　For i = 2 To UBound(tbl1) 　　myPt = myPt & "|(" & Replace(Replace(tbl1(i, 1), "*", ".*"), "?", ".{1}") & ")" 　Next i 　myPt = Mid$(myPt, 2) 　tbl2 = Worksheets("Sheet2").Range("A1").CurrentRegion.Value 　ReDim Preserve ans(1 To UBound(tbl2), 1 To 1) 　With CreateObject("VBScript.RegExp") 　　.Pattern = myPt 　　.Global = True 　　For i = 2 To UBound(tbl2) 　　　If .test(tbl2(i, 1)) Then 　　　　With .Execute(tbl2(i, 1)).Item(0).SubMatches 　　　　　For j = 1 To .Count 　　　　　　If Not IsEmpty(.Item(j - 1)) Then 　　　　　　　ans(i, 1) = tbl1(j + 1, 2) 　　　　　　　Exit For 　　　　　　End If 　　　　　Next j 　　　　End With 　　　End If 　　Next i 　End With 　Worksheets("Sheet2").Range("B1").Resize(UBound(ans)).Value = ans 　End Sub


	【67991】Re:dictionaryオブジェクトについて

山猿 - 11/1/23(日) 9:06 -


	引用なし

	パスワード

>existsのときに、Like演算子がうまく使えないのですが、使うことはできないのでしょうか？
単純なマッチしかできませんね。

正規表現を使う方法もおもしろいですね。
ただ、Yukiさんから回答されているように、直接、Likeを使うのが簡単でしょう。
ただし、シート１のデータが3000件ほどとのことですので、
配列に持って、逐一、シートにアクセスするのは避けたほうがいいでしょうね。
また、マッチしたらExcit Forしてください。


	【67992】Re:dictionaryオブジェクトについて

MIMI - 11/1/24(月) 11:11 -


	引用なし

	パスワード

▼Yuki さん：

返信ありがとうございます
Yukiさんのアドバイスのようにやってみたところ、いまいち
うまく行かず･･･（私の記述がおかしいのかもしれないけど。。。）

下記のように作成してみました

Dim MyD As Object
Dim MyKey, MyItem

Set MyD = CreateObject("scripting.dictionary")

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
　　If Not MyD.exists(Range("A" & i).Value) Then
　　　 MyD.Add Range("A" & i).Value, Range("B" & i).Value
　　End If
Next i

MyKey = MyD.keys
MyItem = MyD.items

Sheets(2).Activate
　For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
　　　For u = 0 To UBound(MyKey)
　　　 If Range("A" & i).Value Like MyKey(u) Then
　　　　　Range("B" & i).Value = MyItem(u)
　　　 End If
　　　Next u
Next i

しかし、このコードだと、とても時間がかかってしまう難点があります
いろいろと試行錯誤してもう少し考えてみます

>　　If MyD.exists(Range("A" & i).Value) Then
>　　　 '↑ココで、指定文字を含むものがあるか？どうか？を判断させたいです
>　　　 ' もう一度聞く
>　　　　If MyD.Item(Range("A" & i).Value) Like "指定文字" Then
>　　　　　 Range("B" & i).Value = MyD.Item(Range("A" & i).Value)
>　　　　End If
>　　End If
>こんな風でどうでしょう。
>検証していないので間違っていたら失礼


	【67993】Re:dictionaryオブジェクトについて

MIMI - 11/1/24(月) 11:21 -


	引用なし

	パスワード

▼ｍｏｍｏさん：

momoさん
アドバイスありがとうございます
正規表現という言葉を初めて知りました

とりあえず、momoさんの記述してくれたコードをそのまま動かしてみたところ、
うまくいかなくて、なんでなのか？調べているところです

コードの意味が分からないことだらけなので、
いろいろと調べてみて、再度、挑戦してみます

また、分からないところが多々でてくると思います
そのときは、聞くことがあるかもしれませんが、よろしくお願いします

>正規表現でSubMatchesを使ってみるとかはどうでしょうね？
>（にしても長いPattern・・・・）
>
>　Option Explicit
>　Sub 正規表現パターン逆引()
>　Dim ans() As Variant, tbl1 As Variant, tbl2 As Variant
>　Dim i As Long, j As Long
>　Dim myPt As String
>　tbl1 = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
>　For i = 2 To UBound(tbl1)
>　　myPt = myPt & "|(" & Replace(Replace(tbl1(i, 1), "*", ".*"), "?", ".{1}") & ")"
>　Next i
>　myPt = Mid$(myPt, 2)
>　tbl2 = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
>　ReDim Preserve ans(1 To UBound(tbl2), 1 To 1)
>　With CreateObject("VBScript.RegExp")
>　　.Pattern = myPt
>　　.Global = True
>　　For i = 2 To UBound(tbl2)
>　　　If .test(tbl2(i, 1)) Then
>　　　　With .Execute(tbl2(i, 1)).Item(0).SubMatches
>　　　　　For j = 1 To .Count
>　　　　　　If Not IsEmpty(.Item(j - 1)) Then
>　　　　　　　ans(i, 1) = tbl1(j + 1, 2)
>　　　　　　　Exit For
>　　　　　　End If
>　　　　　Next j
>　　　　End With
>　　　End If
>　　Next i
>　End With
>　Worksheets("Sheet2").Range("B1").Resize(UBound(ans)).Value = ans
>　End Sub


	【67994】Re:dictionaryオブジェクトについて

MIMI - 11/1/24(月) 11:23 -


	引用なし

	パスワード

▼山猿さん：

アドバイスありがとうございます

なんせ、検索側の件数が多すぎて
時間がかかってしまい、どうしたら、短縮できるのか？
まだまだ悩み中です

>配列に持って、逐一、シートにアクセスするのは避けたほうがいいでしょうね。
>また、マッチしたらExcit Forしてください。

上記の言葉･･･参考にさせていただきます

ありがとうございました


	【67999】Re:dictionaryオブジェクトについて

MIMI - 11/1/24(月) 16:51 -


	引用なし

	パスワード

▼ｍｏｍｏさん：

いろいろと調べてみてなんとなく解読ができかけています
どうしても分からないところがあるので教えてください

>　myPt = Mid$(myPt, 2)
↑上記の意味がいまいちわからないです
　Midのあとの$にはどういう意味があるのですか？

あと、
.count の部分なんですが、
このカウントをどういった単位でカウントされているのかいまいちつかめません

実際のデータ数は3061件なんですが、
.count=3074となってしまって、
ここの部分でｴﾗｰがでて止まってしまいます

そして、下記のコードの.Item(0).SubMatchesの辺が
理解できなくて悩んでます

>With .Execute(tbl2(i, 1)).Item(0).SubMatches
>　　　　　For j = 1 To .Count
>　　　　　　If Not IsEmpty(.Item(j - 1)) Then
>　　　　　　　ans(i, 1) = tbl1(j + 1, 2)
>　　　　　　　Exit For
>　　　　　　End If
>　　　　　Next j
>　　　　End With
　
何度もすみません
ご教授いただけるとありがたいです
お願いします

>　Option Explicit
>　Sub 正規表現パターン逆引()
>　Dim ans() As Variant, tbl1 As Variant, tbl2 As Variant
>　Dim i As Long, j As Long
>　Dim myPt As String
>　tbl1 = Worksheets("Sheet1").Range("A1").CurrentRegion.Value
>　For i = 2 To UBound(tbl1)
>　　myPt = myPt & "|(" & Replace(Replace(tbl1(i, 1), "*", ".*"), "?", ".{1}") & ")"
>　Next i
>　myPt = Mid$(myPt, 2)
>　tbl2 = Worksheets("Sheet2").Range("A1").CurrentRegion.Value
>　ReDim Preserve ans(1 To UBound(tbl2), 1 To 1)
>　With CreateObject("VBScript.RegExp")
>　　.Pattern = myPt
>　　.Global = True
>　　For i = 2 To UBound(tbl2)
>　　　If .test(tbl2(i, 1)) Then
>　　　　With .Execute(tbl2(i, 1)).Item(0).SubMatches
>　　　　　For j = 1 To .Count
>　　　　　　If Not IsEmpty(.Item(j - 1)) Then
>　　　　　　　ans(i, 1) = tbl1(j + 1, 2)
>　　　　　　　Exit For
>　　　　　　End If
>　　　　　Next j
>　　　　End With
>　　　End If
>　　Next i
>　End With
>　Worksheets("Sheet2").Range("B1").Resize(UBound(ans)).Value = ans
>　End Sub


	【68001】Re:dictionaryオブジェクトについて

ｍｏｍｏ - 11/1/24(月) 17:24 -


	引用なし

	パスワード

▼MIMI さん：

>>　myPt = Mid$(myPt, 2)
>↑上記の意味がいまいちわからないです
>　Midのあとの$にはどういう意味があるのですか？
ヘルプでも確認できるかとは思いますが
$が付いた関数は明示的にString型で返すという事です。
欲しいのは文字列データなので$を付けてます。

>あと、
>.count の部分なんですが、
>このカウントをどういった単位でカウントされているのかいまいちつかめません
>
>実際のデータ数は3061件なんですが、
>.count=3074となってしまって、
>ここの部分でｴﾗｰがでて止まってしまいます
.Count を　Ubound(tbl1)-1　に変えるとどうでしょうか？
Sheet1のデータ数と一致すれば良いです。

>そして、下記のコードの.Item(0).SubMatchesの辺が
>理解できなくて悩んでます
正規表現パターン全てに一括で検索を掛けて
何番目のパターンにマッチしたかを探しているコードです。
言葉だけではうまく説明できませんが、たとえば
AAAという文字は
(ABC)|(ccc)|(AAA)|(DDD)
というパターンだと３番目にマッチします。
.Execute(tbl2(i, 1))
で一括でパターンマッチを行って
|で区切られた何番目か？というのがSubMatches
なので、ループしてEmptyじゃないものを探しています。


	【68017】Re:dictionaryオブジェクトについて

Yuki - 11/1/25(火) 14:46 -


	引用なし

	パスワード

▼MIMI さん：
>
>しかし、このコードだと、とても時間がかかってしまう難点があります

例のように規則性があるんでしたら
下記のようでいけそうです。

Sub TESTx()
　　Dim Dic As Object
　　Dim v1　As Variant
　　Dim v2　As Variant
　　Dim i　 As Long
　　
　　With Worksheets("Sheet1")
　　　　v1 = .Range("A1").CurrentRegion.Resize(, 2).Value
　　End With
　　
　　Set Dic = CreateObject("Scripting.Dictionary")
　　For i = 2 To UBound(v1)
　　　　Select Case Left(v1(i, 1), 1)
　　　　　　Case "*", "?"
　　　　　　　　Dic(Replace(Replace(Right(v1(i, 1), Len(v1(i, 1)) - 1), "*", "|"), "?", "-")) = v1(i, 2)
　　　　　　Case Else
　　　　　　　　Dic(Replace(Replace(v1(i, 1), "*", "|"), "?", "-")) = v1(i, 2)
　　　　End Select
　　Next
　　
　　With Worksheets("Sheet2")
　　　　v2 = .Range("A1").CurrentRegion.Resize(, 2).Value
　　　　For i = 2 To UBound(v2)
　　　　　　If Dic.Exists(v2(i, 1)) Then
　　　　　　　　v2(i, 2) = Dic(v2(i, 1))
　　　　　　End If
　　　　Next
　　　　.Range("A1").Resize(UBound(v2), 2).Value = v2
　　End With
End Sub


	【68021】Re:dictionaryオブジェクトについて

MIMI - 11/1/25(火) 16:31 -


	引用なし

	パスワード

▼ｍｏｍｏさん：

ご教授ありがとうございました
なんとか、意味も分かりつつ、うまく動かすことができました

実際の処理では、まだ応用をきかさないといけないので、
試行錯誤やってみます

正規表現･･･
とても勉強になりました

助かりました

ありがとうございました


	【68024】Re:dictionaryオブジェクトについて

山猿 - 11/1/25(火) 20:20 -


	引用なし

	パスワード

テストしないということは、
単なる参考意見くらいの受け止め方のようですね。

あなたが考えている以上に、配列にする効果は大きいですよ。
最初にまとめて配列に取り込み、
Likeで判断した結果を配列に保持、
最後にまとめてシートに書き出すようにすれば、速くなります。

3000件のテストデータで検証したところ、
・シートにアクセスする方法　　35秒くらい
・配列利用　　　　　　　　　　 1秒ちょっと
・ｍｏｍｏさんの正規表現利用　 5秒くらい
速度的にも問題ないでしょう。


	【68089】Re:dictionaryオブジェクトについて

MIMI - 11/1/31(月) 16:39 -


	引用なし

	パスワード

▼Yuki さん：

アドバイスありがとうございます
ただ、-（ﾊｲﾌﾝ）のときもあり、アルファベット[A-Z]一文字入っているときもあって、常に、?のところがﾊｲﾌﾝとは限らないのです･･･（悲）

？（ハテナ）の場所が、ﾊｲﾌﾝかアルファベットどちらでも対応できるようにするにはやはり、dictionaryオブジェクトでは、難しいのでしょうか？

>▼MIMI さん：
>>
>>しかし、このコードだと、とても時間がかかってしまう難点があります
>
>例のように規則性があるんでしたら
>下記のようでいけそうです。
>
>Sub TESTx()
>　　Dim Dic As Object
>　　Dim v1　As Variant
>　　Dim v2　As Variant
>　　Dim i　 As Long
>　　
>　　With Worksheets("Sheet1")
>　　　　v1 = .Range("A1").CurrentRegion.Resize(, 2).Value
>　　End With
>　　
>　　Set Dic = CreateObject("Scripting.Dictionary")
>　　For i = 2 To UBound(v1)
>　　　　Select Case Left(v1(i, 1), 1)
>　　　　　　Case "*", "?"
>　　　　　　　　Dic(Replace(Replace(Right(v1(i, 1), Len(v1(i, 1)) - 1), "*", "|"), "?", "-")) = v1(i, 2)
>　　　　　　Case Else
>　　　　　　　　Dic(Replace(Replace(v1(i, 1), "*", "|"), "?", "-")) = v1(i, 2)
>　　　　End Select
>　　Next
>　　
>　　With Worksheets("Sheet2")
>　　　　v2 = .Range("A1").CurrentRegion.Resize(, 2).Value
>　　　　For i = 2 To UBound(v2)
>　　　　　　If Dic.Exists(v2(i, 1)) Then
>　　　　　　　　v2(i, 2) = Dic(v2(i, 1))
>　　　　　　End If
>　　　　Next
>　　　　.Range("A1").Resize(UBound(v2), 2).Value = v2
>　　End With
>End Sub


	【68090】Re:dictionaryオブジェクトについて

Yuki - 11/1/31(月) 17:32 -


	引用なし

	パスワード

▼MIMI さん：
>ただ、-（ﾊｲﾌﾝ）のときもあり、アルファベット[A-Z]一文字入っているときもあって、常に、?のところがﾊｲﾌﾝとは限らないのです･･･（悲）
>
>？（ハテナ）の場所が、ﾊｲﾌﾝかアルファベットどちらでも対応できるようにする

実際のデータを見てみないと何ともいえません。
どのような時にーでどのような時にアルファベットなのかその関係は？
それとデータと検索の関係がどのようになっているのかも分かりませんし。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

2428 / 13645 ﾂﾘｰ

←次へ　｜　前へ→

ページ：

┃

記事番号：

(SS)C-BOARD v3.8 is Free