既存のファイルからグループ名を表示するエクセルのユーザー定義関数の作成方法について

質問

「A.xls」というファイルに、
　　　　　A　　　　　　　　 B　　　　　　　　　C
1　「所属グループ」　「所属チーム」　　　　「ID」
2　　　　X　　　　　　　　　1　　　　　　　1・3・4・6
3　　　　X　　　　　　　　　2　　　　　　　2・5・7・8・9・15
4　　　　X　　　　　　　　　3　　　　　　　10・11・12・14
5　　　　X　　　　　　　　　4　　　　　　　13・16
6　　　　Y　　　　　　　　　1　　　　　　　1・2・3・9
7　　　　Y　　　　　　　　　2　　　　　　　4・5・11
8　　　　Y　　　　　　　　　3　　　　　　　6・10
9　　　　Z　　　　　　　　　1　　　　　　　1・4・6
10　　　 Z　　　　　　　　　2　　　　　　　2・8・
11　　　 Z　　　　　　　　　3　　　　　　　3・5・7・9

のように管理しているものを、

　　　　　A　　　　　　　　 B　　　　　　　　　C
1　「所属グループ」　　「ID」　　　「所属チーム」
2　　　　X　　　　　　　　　1　　　　　　　　　1
3　　　　X　　　　　　　　　2　　　　　　　　　2
4　　　　X　　　　　　　　　3　　　　　　　　　1
5　　　　X　　　　　　　　　4　　　　　　　　　1
6　　　　X　　　　　　　　　5　　　　　　　　　2
7　　　　X　　　　　　　　　6　　　　　　　　　1
8　　　　X　　　　　　　　　7　　　　　　　　　2
9　　　　X　　　　　　　　　8　　　　　　　　　2
10　　　 X　　　　　　　　　9　　　　　　　　　2
11　　　 X　　　　　　　　　10 　　　　　　　　3
　　　　 ・　　　　　　　　 ・
　　　　 ・　　　　　　　　 ・
　　　　 ・　　　　　　　　 ・

上記のように「所属グループ」をA列に「ID」をB列に置いた
「B.xls」ファイルを作成したいのですが、
既存の関数でやろうとしても上手くできませんでした。

ですので、「A.xls」のC列をデータベースとした、
下記の3つを引数にとるユーザ定義関数を作りたいと
思っているのですが、

所属グループ名　→　　　検索値1
所属ID 　→　　　検索値2
A.xls C列2～　　→　　データベース

マクロの知識があまりない私にはここから先どのようにすればよいか分かりません。
お手数ですがどなたか教えてくれないでしょうか？

回答No.1

Wendy02 · ベストアンサー

こんばんは。

マクロならまだしも、ユーザー定義関数ですと、これは、３次元ですから、なかなかややこしいです。

本来、C列に、「1・3・4・6」のような書き方は、データとして不安定になりやすく、ワン・セルには、ワン・データというほうが扱いやすいです。

今回、あまり、難しくせずに作ってみました。

区切り文字は、「・」としていますが、混在は出来ませんが、違うものなら、「区切り文字」の部分に、任意で入れてください。見つからない場合は、「？」が出ます。

ユーザー定義関数は、シートに置いたままにすると、量が多くなると、配列数式と同じくシートが重くなります。その場合は、値貼り付けしてしまってください。
検索値の大文字・小文字/全角・半角のの区別はありません。

数式例：

=ThreeD(A2,B2,[A.xls]Sheet1!$A$2:$C$11)

コードの登録は、値を出す側のブックの標準モジュールです。間違えないようにしてください。

--------------------------------------------

Public Function ThreeD(ByVal Grp As String, ByVal ID As String, mData As Range, Optional Delim As String)
'引数：検索グループ名,検索ID, データ範囲（３列）,[区切り文字]
Dim myDic As Object ' New Dictionary
Dim ky As Variant
Dim Ar As Variant
Dim c As Variant
Dim v As Variant
Dim x As Variant
Dim i As Long, j As Long
Dim a As Variant, b As Variant
Dim n As String
Dim flg As Boolean
flg = False

If Delim = "" Then Delim = "・"
Set myDic = CreateObject("Scripting.Dictionary")
myDic.CompareMode = 1 'TextCompare

For Each c In mData
　　ky = Trim(c.Value) & "-" & Trim(c.Offset(, 1).Value)
　　Ar = Split(c.Offset(, 2).Value, Delim)
　　For Each v In Ar
　　　　On Error Resume Next
　　　　myDic.Add ky, v
　　　　If Err.Number > 0 Then
　　　　　　myDic.Item(ky) = myDic.Item(ky) & "," & v
　　　　　　Err.Clear
　　　　End If
　　Next v
Next c
For Each x In myDic.Keys
　　n = InStr(1, x, Grp & "-", 1)
　　If n > 0 Then
　　　　a = Mid(x, n + 2)
　　　　b = myDic.Item(x) & ","
　　　　j = InStr(1, b, ID & ",", 1)
　　　　If j > 0 Then
　　　　　　flg = True
　　　　　　Exit For
　　　　End If
　　End If
Next x
If flg Then
　　ThreeD = a
Else
　　ThreeD = "?"
End If
End Function

お礼

ご回答頂きありがとうございました！

こちら試してみたところ、
私の思い描いていたイメージどおりの
動作をしてくれました！！

本当にありがとうございました。

回答No.2

yukika-37

Public Const strDelimiter As String = "・" 'IDの区切り文字
Public Const strOldBookName As String = "Book1"
Public Const strNewBookName As String = "Book3"
Public Const strOldSheetName As String = "Sheet1"
Public Const strNewSheetName As String = "Sheet1"

Function getTeam(ByVal strGroup As String, ByVal intID As Integer) As Integer

　　Dim intTeam As Integer '所属チーム
　　Dim i As Long
　　Dim j As Integer
　　Dim aryID As Variant
　　Dim endRow As Long '検索終了行

　　'検索結果初期化
　　getTeam = -1

　　'検索
　　With Application.Workbooks(strOldBookName).Sheets(strOldSheetName)
　　　　'検索終了行
　　　　endRow = .Range("A" & Rows.Count).End(xlUp).Row
　　　　For i = 1 To endRow
　　　　　　'所属グループで絞込み
　　　　　　If .Cells(i, 1).Text = strGroup Then
　　　　　　　　'IDで絞込み
　　　　　　　　aryID = Split(.Cells(i, 3).Text, strDelimiter)
　　　　　　　　For j = 0 To UBound(aryID)
　　　　　　　　　　If aryID(j) = intID Then　　　　　　　　
　　　　　　　　　　　　'HITしたら所属チームを取得して関数終了
　　　　　　　　　　　　getTeam = .Cells(i, 2).Value
　　　　　　　　　　　　Exit Function
　　　　　　　　　　End If
　　　　　　　　Next
　　　　　　End If
　　　　Next
　　End With

End Function

Sub test()
　　Dim i As Long
　　Dim endRow As Long '検索終了行

　　Application.ScreenUpdating = False

　　With Application.Workbooks(strNewBookName).Sheets(strNewSheetName)
　　　　'検索終了行
　　　　endRow = .Range("A" & Rows.Count).End(xlUp).Row
　　　　For i = 2 To endRow
　　　　　　'所属チーム取得
　　　　　　.Cells(i, 3).Value = getTeam(.Cells(i, 1).Text, .Cells(i, 2).Value)
　　　　Next
　　End With

　　Application.ScreenUpdating = True

End Sub

getTeamに所属グループとIDを渡してやると、所属チームを返します。
検索に失敗したら-1が返ります。
（例：所属グループがY、IDが8）

B.xlsに
　　　　　A　　　　　　　　 B　　　　　　　　　C
1　「所属グループ」　　「ID」　　　「所属チーム」
2　　　　X　　　　　　　　　1　　　　　　　　　
3　　　　X　　　　　　　　　2　　　　　　　　　
4　　　　X　　　　　　　　　3　　　　　　　　　
5　　　　X　　　　　　　　　4　　　　　　　　　
6　　　　X　　　　　　　　　5　　　　　　　　　
7　　　　X　　　　　　　　　6　　　　　　　　　
8　　　　X　　　　　　　　　7　　　　　　　　　
9　　　　X　　　　　　　　　8　　　　　　　　　
10　　　 X　　　　　　　　　9　　　　　　　　　
11　　　 X　　　　　　　　　10 　　　　　　　　
　　　　 ・　　　　　　　　 ・
　　　　 ・　　　　　　　　 ・
　　　　 ・　　　　　　　　 ・

のように値を設定しておいて、test関数を実行すると、

　　　　　A　　　　　　　　 B　　　　　　　　　C
1　「所属グループ」　　「ID」　　　「所属チーム」
2　　　　X　　　　　　　　　1　　　　　　　　　1
3　　　　X　　　　　　　　　2　　　　　　　　　2
4　　　　X　　　　　　　　　3　　　　　　　　　1
5　　　　X　　　　　　　　　4　　　　　　　　　1
6　　　　X　　　　　　　　　5　　　　　　　　　2
7　　　　X　　　　　　　　　6　　　　　　　　　1
8　　　　X　　　　　　　　　7　　　　　　　　　2
9　　　　X　　　　　　　　　8　　　　　　　　　2
10　　　 X　　　　　　　　　9　　　　　　　　　2
11　　　 X　　　　　　　　　10 　　　　　　　　3
　　　　 ・　　　　　　　　 ・
　　　　 ・　　　　　　　　 ・
　　　　 ・　　　　　　　　 ・

のように、所属チームを埋めてくれます。
strOldBookNameを「A」、strNewBookNameを「B」にして、それぞれのシート名を適当なものに設定すれば動くのではないかと。

※A.xlsとB.xlsを同じプロセスで開いていることが条件。
　とりあえずA.xlsを開いて、更に「開く」でB.xlsを開けばOK。

お礼

ご回答ありがとうございました。

私のやり方がいけないのか、
testマクロを実行すると
「インデックスが有効範囲にない」という
エラーが起きてしまいました。

貴重なお時間を私のために割いて頂きありがとうございました。
何が悪かったのか私も勉強しながら、
ソースを追っていきたいと思います。