ＶＢＡで質問です。

Question

こちらのユーザー定義関数は部分一致になっているのですが、
これを絶対一致、前方一致、後方一致、
それぞれ作るとしたらどうすればよいでしょうか。


Function myClassification(S1 As String, R1 As Range) As String
  Dim i As Integer, j As Integer
  Dim V1 As Variant
  V1 = R1.Value
  For i = LBound(V1, 1) To UBound(V1, 1)
    For j = LBound(V1, 2) + 1 To UBound(V1, 2)
      If V1(i, j) <> "" And InStr(1, S1, V1(i, j), vbTextCompare) > 0 Then
        myClassification = V1(i, 1)
        Exit Function
      End If
    Next j
  Next i
End Function


以下のサイトからとってきました。
http://web-tan.forum.impressrd.jp/e/2012/06/05/12759

cj_mover · Accepted Answer

' ' ///

Public Function afClassification(ByVal S1, ByVal R1 As Range, Optional ByVal P1 = 2)
Dim mtxSrc, mtxRtn, mtxClass, mtxParts
Dim v, vv
Dim ubXR As Long, ubYR As Long
Dim ubX As Long, ubY As Long
Dim nLen As Long, nPos As Long
Dim cnParts As Long, cnSrc As Long

　　If UCase(TypeName(S1)) = "RANGE" Then
　　　　If S1.Count = 1 Then
　　　　　　ReDim mtxSrc(1, 1) As String
　　　　　　mtxSrc(1, 1) = S1.Value
　　　　　　ubYR = 1: ubXR = 1
　　　　Else
　　　　　　mtxSrc = S1.Value
　　　　　　ubYR = UBound(mtxSrc): ubXR = UBound(mtxSrc, 2)
　　　　End If
　　Else
　　　　ReDim mtxSrc(1, 1) As String
　　　　mtxSrc(1, 1) = S1
　　　　ubYR = 1: ubXR = 1
　　End If

　　ReDim mtxRtn(ubYR, ubXR)

　　mtxClass = R1.Columns(1).Value
　　ubY = UBound(mtxClass)
　　ubX = R1.Columns.Count - 1
　　mtxParts = R1.Resize(, ubX).Offset(, 1).Value

　　Select Case P1
　　Case 2　'　部分一致
　　　　For Each vv In mtxSrc
　　　　　　cnParts = 0
　　　　　　For Each v In mtxParts
　　　　　　　　If v <> "" Then
　　　　　　　　　　If InStr(vv, v) Then Exit For
　　　　　　　　End If
　　　　　　　　cnParts = cnParts + 1
　　　　　　Next
　　　　　　If cnParts < ubY * ubX Then
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = mtxClass(cnParts Mod ubY + 1, 1)
　　　　　　Else
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = CVErr(xlErrNA) '　該当無しエラー
　　　　　　End If
　　　　　　cnSrc = cnSrc + 1
　　　　Next
　　Case 0　'　完全一致
　　　　For Each vv In mtxSrc
　　　　　　cnParts = 0
　　　　　　nLen = Len(vv)
　　　　　　For Each v In mtxParts
　　　　　　　　If v <> "" Then
　　　　　　　　　　If InStr(vv, v) = 1 Then
　　　　　　　　　　　　If Len(v) = nLen Then Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　cnParts = cnParts + 1
　　　　　　Next
　　　　　　If cnParts < ubY * ubX Then
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = mtxClass(cnParts Mod ubY + 1, 1)
　　　　　　Else
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = CVErr(xlErrNA) '　該当無しエラー
　　　　　　End If
　　　　　　cnSrc = cnSrc + 1
　　　　Next
　　Case 1　'　前方一致
　　　　For Each vv In mtxSrc
　　　　　　cnParts = 0
　　　　　　For Each v In mtxParts
　　　　　　　　If v <> "" Then
　　　　　　　　　　If InStr(vv, v) = 1 Then Exit For
　　　　　　　　End If
　　　　　　　　cnParts = cnParts + 1
　　　　　　Next
　　　　　　If cnParts < ubY * ubX Then
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = mtxClass(cnParts Mod ubY + 1, 1)
　　　　　　Else
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = CVErr(xlErrNA) '　該当無しエラー
　　　　　　End If
　　　　　　cnSrc = cnSrc + 1
　　　　Next
　　Case 3　'　後方一致
　　　　For Each vv In mtxSrc
　　　　　　cnParts = 0
　　　　　　nLen = Len(vv)
　　　　　　For Each v In mtxParts
　　　　　　　　If v <> "" Then
　　　　　　　　　　nPos = InStr(vv, v)
　　　　　　　　　　If nPos Then
　　　　　　　　　　　　If nPos = nLen - Len(v) + 1 Then Exit For
　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　　　cnParts = cnParts + 1
　　　　　　Next
　　　　　　If cnParts < ubY * ubX Then
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = mtxClass(cnParts Mod ubY + 1, 1)
　　　　　　Else
　　　　　　　　mtxRtn(cnSrc Mod ubYR + 1, cnSrc \ ubYR + 1) = CVErr(xlErrNA) '　該当無しエラー
　　　　　　End If
　　　　　　cnSrc = cnSrc + 1
　　　　Next
　　Case Else: afClassification = CVErr(xlErrNum): Exit Function '　引数エラー
　　End Select
　　afClassification = mtxRtn
End Function
' ' ///

cj_mover · Answer

Ans.#1,3-5です。追加レスです。

> 「りんご みかん」のようなキーワード。登録では、
> みかん りんご」と登録してある場合でもひっかかる
> ようにするようなことって難しいでしょうか

ふと思ったのですが、もしかして、
今回ご質問の関数は、
検索するキーが複数のセル範囲にあるという前提だったものを、
ひとつのセルに書かれた区切られた複数の文字列それぞれをキーにする、
ということを意図されているのでしたら、
難しい、というより、今より簡単に書けるとは思いますし、
処理も多少軽くなります。
また機会があればお応えするかも知れません。

cj_mover · Answer

Ans.#1,3,4です。#4お礼欄拝見しました。

> 「りんご みかん」のようなキーワード。登録では、
> みかん りんご」と登録してある場合でもひっかかる
> ようにするようなことって難しいでしょうか

難しくはないですし、#3,4の関数に組み込むことは可能ですが、
またあらためて機会があれば、と思います。
即応しない理由は２つ、
まず、今回はそういう前提で回答していませんから、
特に計算速度を問題にもしている訳ですから、
新たな機能を加えれば必然遅くなってしまうものをどう対処するか、
既述のものに書き足すというより、設計からやり直し
になるかも、ということです。
それを踏まえて２つめの理由として、
今手元にあるものについて、しっかり検証をして、
これでいい、とか、少し違う、とか、
予定の要求仕様に適ったものであるのかを確認する作業が
とても大事です。
例えば、＃２さんがお書きになったものは、私が書いたものとは、
（完全一致以外では）違う結果を返す仕様になっています。
（第二引数に指定する範囲がＡ１を先頭にした範囲であれば試せます）
要求仕様への解釈がハッキリ確定的なものになれば、
私が提供したものも、今よりは整理された記述になります。
（修正や訂正をし易く書いている代りに機能追加が難しい書き方を選んだ）
そこに何かを書き足そうという場合は、どうしても
整理した記述に直すという段階を踏んでから取り組むことになります。
求める結果を返しているのかどうかの確認がないと、
次に進むのは難しいのです。
逆に言うと、幾つかある解釈の内のひとつの解釈を前提にして
お応えしているので、こちらでは確かめようのない点が
まだ残っているのです。
さしあたり、当初求めていた結果とは違う、というようなことが
あれば、それはそれで対応するつもりでいますけれど、
今は、何か付け足せる状況ではないと考えています。

お礼欄への返信は以上です。

cj_mover · Answer

Ans.#1です。補足コメント、拝見しました。（ひとつの投稿に収まらないので２回に分けて返信します）計算を速める方向で、２つの関数を挙げておきます。　Function myClassification これは、#1と同じ仕様で処理を15~20%速めました。※ 　Function afClassification こちらは、#1と同じ仕様同じ使い方なのですが、配列数式としても確定できるようにすることで、単矩形範囲（ひとつの連続した四角いセル範囲）に適用した数式の戻り値を纏めて計算させることが出来るので、 30~35%速くなります。※ （※数値はこちらの環境でこちらが用意したダミーサンプルでのテスト結果。）例えば、第一引数S1に指定する文字列が、A2:C1001に連続してあり、第二引数R1に指定する範囲が、G2:AJ201にある、というような場合、 A2:C1001と同じ行数同じ列数のセル範囲（例えばD2:F1001）（数式を設定する単矩形範囲）全体を選択した状態から、先頭のセル（例ではD2）に、　=afClassification(A2:C1001,G2:AJ201,2) のようにタイプして続けて、[Ctrl]+[Shift]+[Enter]キーで数式を確定すると、数式バーでは　{=afClassification(A2:C1001,G2:AJ201,2)} のように、数式が中括弧で括られ、配列数式（FormulaArray）として設定されたことになります。 Function afClassification は配列数式を設定した範囲全体に対して、一度の計算処理で複数の値を返します。第一引数に単セルや文字列を直値で指定した（配列数式ではない）場合でも、こちらの関数の方が微かに速い結果を返しました。処理を速くする、ということで考えると、遅くなる原因の多くは、テキストモード（vbTextCompare や Option Compare Text）にあります。 [全角｜半角][大文字｜小文字]を区別しても良い、という運用が可能なら、以下の記述の　Option Compare Text　'　▼ これを１行まるごと削除すれば、さらに50~55%早くなります。また、これから使うユーザー定義関数が決まったなら、関数専用のアドインファイルとして関数を保存しておいて、 Excelからアドインをインストールするようにすれば、（バージョンによって効果の程は異なりますが）もう少しの時短が見込めるようです。速くするという意味では、無駄なものを削いでいく作業が重要ですが、その為には、仕様を明確に詳らかに決めることも大きな要素です。汎用性やまだ手を加えることを意識すると、どうしても冗長なものになります。ただ、基本設計としては、それなりのものが書けているとは思うので、後は、実際にお使いになる状況条件に合わせてより特化する方向で、仕上げとかメンテとかチューニングとか、鍛えてやってもいいです。こちらとしては、やりつくした訳でもないのですが、これ以上手を加えるつもりもありません。何かもっと圧倒的に速くなるような方法もあるかも知れません。アイディアだけで試してないものもあるのですが、既に１０通り以上書いて試した後なので、もうここら辺にしておきます。動作の確認はくれぐれも慎重にしてくださいね。書き切れないので説明コメントは添えませんが、疑問があればお応えします。以下、先頭の３行は必ず、標準モジュールの先頭に書くようにしないとコンパイルエラーになりますので、以下の記述は、新規の標準モジュールに貼り付けて試すようにしてください。不要となった（使わないと決めた）関数は削除した方がいいですけれど、先頭の３行は、間違って消さないようにしてください。（文字数制限の都合で２回の投稿に分けますが、この次の行からは次の投稿まで続けて、すべてひとつのモジュールに貼り付けてください。） ' /// Option Explicit Option Base 1 Option Compare Text　'　▼ ' ' /// Public Function myClassification(ByVal S1 As String, ByVal R1 As Range, _ 　　　　　　　　　　　　　　　　Optional ByVal P1 = 2) Dim mtxClass, mtxParts Dim v Dim ubX As Long, ubY As Long Dim nLen As Long, nPos As Long Dim cn As Long 　　mtxClass = R1.Columns(1).Value 　　ubY = UBound(mtxClass) 　　ubX = R1.Columns.Count - 1 　　mtxParts = R1.Resize(, ubX).Offset(, 1).Value 　　Select Case P1 　　Case 2　'　部分一致　　　　For Each v In mtxParts 　　　　　　If v <> "" Then 　　　　　　　　If InStr(S1, v) Then Exit For 　　　　　　End If 　　　　　　cn = cn + 1 　　　　Next 　　Case 0　'　完全一致　　　　nLen = Len(S1) 　　　　For Each v In mtxParts 　　　　　　If v <> "" Then 　　　　　　　　If InStr(S1, v) = 1 Then 　　　　　　　　　　If Len(v) = nLen Then Exit For 　　　　　　　　End If 　　　　　　End If 　　　　　　cn = cn + 1 　　　　Next 　　Case 1　'　前方一致　　　　For Each v In mtxParts 　　　　　　If v <> "" Then 　　　　　　　　If InStr(S1, v) = 1 Then Exit For 　　　　　　End If 　　　　　　cn = cn + 1 　　　　Next 　　Case 3　'　後方一致　　　　nLen = Len(S1) 　　　　For Each v In mtxParts 　　　　　　If v <> "" Then 　　　　　　　　nPos = InStr(S1, v) 　　　　　　　　If nPos Then 　　　　　　　　　　If nPos = nLen - Len(v) + 1 Then Exit For 　　　　　　　　End If 　　　　　　End If 　　　　　　cn = cn + 1 　　　　Next 　　End Select 　　Select Case cn 　　Case 0 　　　　myClassification = CVErr(xlErrNum)　'　引数エラー　　Case ubY * ubX 　　　　myClassification = CVErr(xlErrNA)　'　該当無しエラー　　Case Else 　　　　myClassification = mtxClass(cn Mod ubY + 1, 1) 　　End Select End Function ' ' /// ' （次の投稿のスクリプトに続く ... ）

WindFaller · Answer

こんばんは。あえて、Like演算子で作りました。２次元配列もやめ、構造も単純化しました。検索文字で、含められないのは、いわゆるメタキャラクタに関するものだと思います。それから、以前の自分自身の発言を翻しはしていますが、構造的に、あえて、String型にしています。一行加えるなら、Variant でもよいと思います。長く使って調べたわけではありませんから、不具合があるかもしれません。関数は、先頭のMyをとって「　i　」にしています。ただ、普段は、このようなLike演算子でコードは書きませんね。Compare Text モードが実に浮いています。 '// Option Compare Text　'モジュールトップへ Function iClassification(wd As String, Rng As Range, Optional k As Variant = 0) As String 　'Option: 0 or なし=絶対一致; 1= 前方一致; 2 =後方一致;3 =含まれる　Dim c As Variant 　Dim cmp As String 　For Each c In Rng 　If c.Value <> "" And c.Column <> 1 Then 　　 cmp = Switch(k = 0, c, k = 1, c & "?*", k = 2, "?*" & c, k = 3, "?*" & c & "?*") 　　　　 If wd Like cmp Then 　　　　　 iClassification = Rng.Cells(c.Row, 1).Value 　　　　　 Exit Function 　　　　 End If 　　 End If 　Next c End Function '// ただ、実際の処理の場合は、ユーザー定義関数を置いておかずに、値貼り付けや、最初からマクロで値を貼り付けていったほうが、ワークシートの負担は少ないだろうと思います。

cj_mover · Answer

こんにちは。

> ... 部分一致 ... 絶対一致、前方一致、後方一致、それぞれ作る ...
関数を増やすと管理が大変ですから、
ひとつの（現在の）関数を４通り使えるようにするのが普通かと思います。

検索語の実際がある程度解れば、
Like演算子とOption Compareの組合わせで簡単なやり方も
あるにはある、のですが、
幾つかの文字を検索語に含める事が出来ないという事情があって、
使い物にはなりません。

という理由で、InStr関数とLen関数を使って４通りを表現します。

第３の引数を追加して、これを省略（または2っを指定）すれば、
従来と同じ、部分一致の結果を返します。
第３の引数の使い分けは、
　　0　　完全一致　　=myClassification(A3,A$1:AV$39,0)
　　1　　前方一致　　=myClassification(A3,A$1:AV$39,1)
　　2　　部分一致　　=myClassification(A3,A$1:AV$39,2)
　 省略　部分一致　　=myClassification(A3,A$1:AV$39)
　　3　　後方一致　　=myClassification(A3,A$1:AV$39,3)
のように数値の指定によって判定方法を可変にしています。

また、「ユーザー定義関数」[＝シート上で使う関数]
ということですので、
この場合のお約束で、戻り値をVariant型に書換えています。

現在の関数をコメントブロックするか削除するかしてから、
以下の関数を（必ず）モジュールの先頭に貼り付けてください。
こちらではダミーサンプルを用意して動作を確認しました。

' ' ///　↓モジュール先頭
Option Explicit
' ' ///　↓モジュール先頭の宣言部
Public Enum 一致
　　完全一致　'　= 0
　　前方一致　'　= 1
　　部分一致　'　= 2
　　後方一致　'　= 3
End Enum
' ' ///
Public Function myClassification(ByVal S1 As String, ByVal R1 As Range, _
　　　　　　　　　　　　　　　　Optional ByVal P1 As 一致 = 部分一致) As Variant
Dim lenS As Long, lenV As Long, pos As Long, flg As Boolean
Dim i As Long, j As Long
Dim V1 As Variant
　　V1 = R1.Value
　　lenS = Len(S1)
　　For i = LBound(V1, 1) To UBound(V1, 1)
　　　　For j = LBound(V1, 2) + 1 To UBound(V1, 2)
　　　　　　If V1(i, j) <> "" Then
　　　　　　　　lenV = Len(V1(i, j))
　　　　　　　　pos = InStr(1, S1, V1(i, j), vbTextCompare)
　　　　　　　　Select Case P1
　　　　　　　　Case 完全一致: flg = (pos = 1) And (lenV = lenS)
　　　　　　　　Case 前方一致: flg = pos = 1
　　　　　　　　Case 部分一致: flg = pos > 0
　　　　　　　　Case 後方一致: flg = pos = lenS - lenV + 1
　　　　　　　　End Select
　　　　　　　　If flg Then
　　　　　　　　　　myClassification = V1(i, 1)
　　　　　　　　　　Exit Function
　　　　　　　　End If
　　　　　　End If
　　　　Next j
　　Next i
End Function
' ' ///

ＶＢＡで質問です。

' ' ///

Ans.#1,3-5です。

Ans.#1,3,4です。

Ans.#1です。

こんばんは。

こんにちは。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング