Excel2013でVBAで対応した列の種類毎に名前を定義する

Question

お世話になります。
Excel2013で、添付のように例えばB2:B6まで穀物と入っていれば、D2:D6セルに「穀物」という名前を定義し、以下同様にB7:B9は野菜なのでD7:D9に「野菜」という名前を定義する、みたいにしたいのですが、どうすればよろしいでしょうか？対象は、2行目から最終行までです。定義する数が多いので、なるべく高速で処理できる書き方の方がありがたいです。

VBAでの名前の定義は、あまり向いていないという話はありますが、名前の定義のやり方が分からない方に使っていただくので、申し訳ございませんがよろしくお願いいたします。

WindFaller · Accepted Answer

面倒なアルゴリズムなど使わずに、Dictionary オブジェクトでやってみました。

'//
Sub RegistNames()
　　Dim dic As Object
　　Dim c As Variant, i As Long
　　Dim adr As String, aRng As Range
　　Dim n As String, buf As String
　　Set dic = CreateObject("Scripting.Dictionary")
　　'2行目から
　　For Each c In Range("B2", Cells(Rows.Count, 2).End(xlUp))
　　　'種類の名目が存在してない時
　　　　If Not Dic.exists(Trim(c.Value)) Then
　　　　　　dic.Add Trim(c.Value), c.Address(0, 0)　'
　　　　Else
　　　　　　dic.Item(c.Value) = dic.Item(c.Value) & "," & c.Address(0, 0)
　　　　End If
　　Next c
　　'以下で名前の登録が始まる
　　For i = 0 To dic.Count - 1
　　　　buf = dic.Items()(i)
　　　　If buf <> "" Then
　　　　　'範囲をつなぎ合わせる
　　　　　　Set aRng = Application.Union(Range(buf), Range(buf))
　　　　　　adr = ActiveSheet.Name & "!" & aRng.Offset(, 2).Address(1, 1)　'Offset(,2)は、B列の2つ右先
　　　　　　n = dic.Keys()(i)
　　　　　　Names.Add Name:=n, RefersTo:="=" & adr
　　　　　　adr = "": n = ""
　　　　End If
　　Next i
　　Set dic = Nothing
End Sub

「VBAでの名前の定義は、あまり向いていないという話」
たぶん、これは、教えて！gooでの言い出しっぺは私だと信じています。トラブった時の処理の仕方がややこしいからです。たぶん、そういう場合は、過去ログにその対処法が出ていると思います。

WindFaller · Answer

それは、良かったでした。

>adrに少し付け足して、
>adr = "'" & ActiveSheet.Name & "'!" & aRng.Offset(, 2).Address(1, 1)
>のようにすると、（）付きのシートも通常のシートもどちらも動作しました。

うーん、やはり私の場合は、Nameの取り扱いは、1000回に1つ程度しか使わないから、いつまでも分からなかったと思います。このシングルクォートは、自ブックの自シート(ActiveSheet)では入らなかったような気がしたのですが、正直なところ、これについては、私の守備範囲外です。ただ、この件については、覚えておくようにします。

fujillin · Answer

ANo2です。

自己解決なさったとのことなので良かったです。
私が質問文を見落としていました。申し訳ありませんでした。

WindFaller · Answer

#1の補足についてです。

もちろん、標準モジュールで書いているかとは思いますが、今のところ、このぐらいしか思いつきません。

Application. という単語を先頭に入れてください。

Application.Names.Add Name:=n, RefersTo:="=" & adr

後は、ローカルウィンドウで、その変数の中身を調べてみないとなんとも言えません。ここで、矛盾が生じていたら、それを直さないといけません。

VBEditor 内のローカルウィンドウの状態

fujillin · Answer

こんにちは

回答しようとしたら、もう#1様の回答がありましたね。

私もDictionariyで考え始めたけれど、プリミティブにチェック用配列にしてみました。
あまり要領のよい方法ではありませんが、作ってみたので載せておきます。

Sub Sample()
　Dim r As Long, rw As Long, rMax As Long
　Dim nam As String, rng As Range, chk() As Boolean

rMax = Cells(Rows.Count, 2).End(xlUp).Row
　ReDim chk(rMax)
　For r = 2 To rMax
　　chk(r) = True
　Next r

For rw = 2 To rMax
　　If Cells(rw, 2) = Empty Then
　　　chk(rw) = False
　　ElseIf chk(rw) Then
　　　Set rng = Cells(rw, 2)
　　　nam = rng.Text
　　　For r = rw To rMax
　　　　If Cells(r, 2) = nam Then
　　　　　Set rng = Application.Union(rng, Cells(r, 2))
　　　　　chk(r) = False
　　　　End If
　　　Next r
　　　Names.Add Name:=nam, RefersTo:="=" & rng.Address
　　End If
　Next rw
End Sub

Excel2013でVBAで対応した列の種類毎に名前を定義する

面倒なアルゴリズムなど使わずに、Dictionary オブジェクトでやってみました。

それは、良かったでした。

ANo2です。

#1の補足についてです。

こんにちは

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

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

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

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