Excel VBA質問箱 IV

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

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


2429 / 13646 ツリー ←次へ | 前へ→

【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オブジェクトについて momo 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オブジェクトについて momo 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演算子は使えないのでしょうか?
あいまい検索的な感じにアイテムをヒットさせたいのですが
どうもうまくいかなくて困ってます

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

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

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

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

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

シート2
A列
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オブジェクトについて
発言  momo  - 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を使うのが簡単でしょう。
ただし、シート1のデータが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さん
アドバイスありがとうございます
正規表現という言葉を初めて知りました

とりあえず、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 -

引用なし
パスワード
   ▼momo さん:

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

> 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オブジェクトについて
発言  momo  - 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)
というパターンだと3番目にマッチします。
.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 -

引用なし
パスワード
   ▼momo さん:

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

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

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

助かりました

ありがとうございました

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

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

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

3000件のテストデータで検証したところ、
・シートにアクセスする方法  35秒くらい
・配列利用           1秒ちょっと
・momoさんの正規表現利用  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]一文字入っているときもあって、常に、?のところがハイフンとは限らないのです・・・(悲)
>
>?(ハテナ)の場所が、ハイフンかアルファベットどちらでも対応できるようにする

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

2429 / 13646 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free