[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『VBAの配列で検索を』(メガネケース)
いつも、お世話になります。
B列に商品名A(正規名)、C列に商品名B(略名)のデータがあります。
C列の商品名B(略名)は、B列の商品名A(正規名)に含まれます。
しかし、両列の商品名には、途中に空白が入っていたり、半角全角もあり、データのないセルもあります。
D列に、C列の略名の正規名(A列の)を出したいです。
VBAの配列で処理するには、どのようにしたらいいでしょうか。よろしくお願いします。
[a] [b] [c] [d]
[1] 商品名A(正規名) 商品名B(略名) 略名を正規名に
[2] リン ゴスka パイ ナップルル パイナップ ルルA
[3] ばななーな ba8 なし
[4] イチ ゴ イチゴ12
[5]s みか あんまん メロ ンパンナ PA メロン パンナ
[6] ば ななーな ばななーな ba8
[7]パイナップ ルルA
[8]イチゴ12 はっさくb
[9] s み かあんまん s みか あんまん
[9]PA メロン パンナ リンゴス リン ゴスka
< 使用 Excel:Excel2013、使用 OS:Windows7 >
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.