[[20150301130650]]　『ＶＢＡの配列で検索を』（メガネケース）　ページの最後に飛ぶ

『ＶＢＡの配列で検索を』（メガネケース）

いつも、お世話になります。
Ｂ列に商品名Ａ（正規名）、Ｃ列に商品名Ｂ（略名）のデータがあります。
Ｃ列の商品名Ｂ（略名）は、Ｂ列の商品名Ａ（正規名）に含まれます。
しかし、両列の商品名には、途中に空白が入っていたり、半角全角もあり、データのないセルもあります。

Ｄ列に、Ｃ列の略名の正規名（Ａ列の）を出したいです。
ＶＢＡの配列で処理するには、どのようにしたらいいでしょうか。よろしくお願いします。

[a]　　　　　[b]　　　　　　　　　　　　　　　[c]　　　　　　　　　　　　　[d]
[1]　　　商品名Ａ（正規名）　　　　　商品名Ｂ（略名）　　　　　略名を正規名に

[2] リン　ゴスka 　　　　　　　パイ　ナップルル　　　　パイナップ　ルルＡ
[3] ばななーな　ba8　　　　　　なし
[4]　　　　　　　　　　　　　　　　イチ　ゴ　　　　　　　　　　ｲﾁｺﾞ12
[5]s みかあんまん　　　　　　メロ　　ンパンナ　　　　　　PA　ﾒﾛﾝﾊﾟﾝﾅ
[6]　　　　　　　　　　　　　　　　ばななーな　　　　　　　　ばななーな　ba8
[7]パイナップ　ルルＡ
[8]ｲﾁｺﾞ12　　　　　　　　　　　　　はっさくｂ
[9]　　　　　　　　　　　　　　　　s　　み　かあんまん　　　　s みかあんまん
[9]PA　ﾒﾛﾝﾊﾟﾝﾅ　　　　　　　　ﾘﾝｺﾞｽ　　　　　　　　　　　　リン　ゴスka

＜使用 Excel：Excel2013、使用 OS：Windows7 ＞

何を質問したいか解りません。今一度、質問内容を確認された方がいいのでは
シート内の整合性・一貫性は何処に有るのですか？
Ｂ列とＣ列との関連性が見出せない。自己中では理解できません。
（私も初心者） 2015/03/01(日) 15:24

これだと、どうですか。

 Sub test()
    Dim v
    Dim dic As Object
    Dim tmp As String
    Dim i As Long
    Dim k

    v = Range("a1").CurrentRegion.Resize(, 2).Value

    Set dic = CreateObject("Scripting.Dictionary")

     For i = 2 To UBound(v)
        tmp = Replace(Replace(v(i, 1), " ", ""), "　", "")
        dic(tmp) = v(i, 1)
     Next

    For i = 2 To UBound(v)
        If Not IsEmpty(v(i, 2)) Then
            tmp = Replace(Replace(v(i, 2), " ", ""), "　", "")
            For Each k In dic.keys
                If InStr(1, k, tmp, vbTextCompare) > 0 Then
                    Cells(i, 3).Value = dic(k)
                    Exit For
                End If
            Next
        End If
    Next

 End Sub
（マナ） 2015/03/01(日) 15:49

 マナさんの二番煎じだけどコードを書いたのでアップしておきます。

 Sub test()
    Dim dic As Object
    Dim c As Range
    Dim v As Variant
    Dim x As Long
    Dim i As Long
    Dim k As String
    Dim z As Variant

    Set dic = CreateObject("Scripting.Dictionary")
    x = Range("A" & Rows.Count).End(xlUp).Row
    ReDim v(1 To x - 1, 1 To 1)

    For Each c In Range("A2:A" & x)
        k = StrConv(StrConv(Replace(Replace(c.Value, " ", ""), "　", ""), vbLowerCase), vbNarrow)
        dic(k) = c.Value
    Next

    For Each c In Range("B2:B" & x)
        i = i + 1
        If Len(c.Value) > 0 Then
            k = StrConv(StrConv(Replace(Replace(c.Value, " ", ""), "　", ""), vbLowerCase), vbNarrow)
            For Each z In dic
                If z Like "*" & k & "*" Then
                    v(i, 1) = dic(z)
                    Exit For
                End If
            Next
        End If
    Next

    Range("C2").Resize(UBound(v, 1)).Value = v

 End Sub

（β） 2015/03/01(日) 16:03

すいません、列間違えてましたので再投稿

 Sub test2()
    Dim v
    Dim dic As Object
    Dim tmp As String
    Dim i As Long
    Dim k

    With Range("a1").CurrentRegion
        .Columns(4).Offset(1).ClearContents
        v = .Resize(, 2).Offset(, 1).Value
    End With

    Set dic = CreateObject("Scripting.Dictionary")

     For i = 2 To UBound(v)
        tmp = Replace(Replace(v(i, 1), " ", ""), "　", "")
        dic(tmp) = v(i, 1)
     Next

    For i = 2 To UBound(v)
        If Not IsEmpty(v(i, 2)) Then
            tmp = Replace(Replace(v(i, 2), " ", ""), "　", "")
            For Each k In dic.keys
                If InStr(1, k, tmp, vbTextCompare) > 0 Then
                    Cells(i, 4).Value = dic(k)
                    Exit For
                End If
            Next
        End If
    Next

 End Sub

（マナ） 2015/03/01(日) 16:06

 あまりにも二番煎じだったので、無理やり（？）別案で。
 二重ループをなくしてみました。

 Sub test2()
    Dim reg As Object
    Dim mt As Object
    Dim s As String
    Dim dic As Object
    Dim c As Range
    Dim v As Variant
    Dim x As Long
    Dim i As Long
    Dim k As String
    Dim z As String

    Set dic = CreateObject("Scripting.Dictionary")
    Set reg = CreateObject("VBScript.RegExp")

    x = Range("A" & Rows.Count).End(xlUp).Row
    ReDim v(1 To x - 1, 1 To 1)

    For Each c In Range("A2:A" & x)
        k = StrConv(StrConv(Replace(Replace(c.Value, " ", ""), "　", ""), vbLowerCase), vbNarrow)
        dic(k) = c.Value
    Next

    s = vbTab & Join(dic.keys, vbTab) & vbTab
    Range("F1").Value = s
    For Each c In Range("B2:B" & x)
        i = i + 1
        If Len(c.Value) > 0 Then
            k = StrConv(StrConv(Replace(Replace(c.Value, " ", ""), "　", ""), vbLowerCase), vbNarrow)
            reg.Pattern = vbTab & "[^" & vbTab & "]*" & k & ".*?" & vbTab
            Set mt = reg.Execute(s)
            If mt.Count > 0 Then
                z = Mid(s, mt(0).firstindex + 2, mt(0).Length - 2)
                v(i, 1) = dic(z)
            End If
        End If
    Next

    Range("C2").Resize(UBound(v, 1)).Value = v

 End Sub

（β） 2015/03/01(日) 17:34

みなさま、つたない質問だったのに、回答してくださって、ありがとうございます。内容が理解できるように、今から勉強します。
しばらくして、わからない部分を、まとめて質問させてください。
よろしくお願いします。
（メガネケース） 2015/03/01(日) 19:47

コメント返信：

[ 一覧(最新更新順) ]

[[20150301130650]] 『ＶＢＡの配列で検索を』（メガネケース） ページの最後に飛ぶ

[[20150301130650]]　『ＶＢＡの配列で検索を』（メガネケース）　ページの最後に飛ぶ