VBA 結合セルを扱う

こんにちは。
派犬事務員のコロ子です。

あるシステムからデータをダウンロードすると、こんな感じのエクセルの表になって落ちてくる。

表1

見やすいようにセルが結合されている。
わざわざそういう風に作ってくれているのはありがたいけど、これを加工するとなるとちょっと扱いにくい。

結合されたセルの扱いについて考える

A1～A4が結合されている場合

結合セルA1：A4を選択するには、セルの範囲のどこを指定しても結合セルが選択される。
Cells(1, 1).Select
Cells(2, 1).Select
Cells(3, 1).Select
Cells(4, 1).Select
上記4つは全部同じ動きをする。

値を取るのはどうだろう。
Cells(1, 1).Value　←このときだけ値が取れる　
Cells(2, 1).Value　←空が取得
Cells(3, 1).Value　←空が取得
Cells(4, 1).Value　←空が取得
値は結合の一番上のセルでのみ取得可能。
確かにセルの結合を解除すると一番上のセルに値が入って他のセルは空欄になる。
なるほど、こういう仕様かぁ。

ちなみに、

①のように横に結合されている場合は一番左のセル（B2セル）
②のように縦横に結合されている場合は一番左上のセル（B4セル）
で値が取れる。

仕組みが分かったので、表1からサンプル名を取得してみる。

Sub SampleName()

Dim i As Long
For i = 4 To 17
    If Cells(i, 2).Value <> "" Then
        Debug.Print Cells(i, 2).Value
    End If
Next i

End Sub

次に、表1より「日付」「サンプル名」「ロット」「データ」を取得してみる。
Selectionで結合セルを選択して、アドレスから値を取得する方法でやってみる。

Sub データ()

    Dim ran As Range
    
    For Each ran In Range("D4:H17")
    
        Debug.Print "日付：" & セルの値_日付(ran, 2)
        Debug.Print "サンプル名：" & セルの値(ran, 2)
        Debug.Print "ロット番号：" & セルの値(ran, 3)
        Debug.Print "データ：" & ran.Value
    
    Next ran

End Sub

Function セルの値(ran As Range, c As Long) As String
'引数cは列番号
    
    Cells(ran.Row, c).Select

    Dim myAdress As Variant
    myAdress = Split(Selection.Address, "$")
    
    Dim r As Long
    '単独セルの場合
    If InStr(Selection.Address, ":") = 0 Then
        r = myAdress(2)
    '結合されている場合「：」を除く
    Else
        r = Left(myAdress(2), Len(myAdress(2)) - 1)
    End If
        
    セルの値 = Cells(r, c).Value
    
End Function

Function セルの値_日付(ran As Range, r As Long) As String
'引数rは行番号

    Cells(r, ran.Column).Select

    Dim myAdress As Variant
    myAdress = Split(Selection.Address, "$")
    
    Dim c As String
    c = myAdress(1)
        
    セルの値_日付 = Cells(r, c).Value & Cells(r + 1, ran.Column).Value

End Function

・セルのアドレスは$B$4:$B$10のような形になっているので、＄で区切って配列に入れる。
・縦に結合されている場合は、配列の2番目が行番号。「：」が入っていないなければ単独セル。「：」が入っている場合は：を除く。
・横に結合されている場合は配列の1番目が列番号。列番号は英文字で取得。

この場合Selectionでセルを選択しているのでマクロ実行中は絶対にエクセルを触らないように注意。

******************************************

この記事を公開したら正しい方法を教えてもらった。
こちらをチェック
↓
koroko.hatenablog.com

【恐怖】VBA Workbooks.Openでファイルが消える！

こんにちは。
派犬事務員のコロ子です。

何年か前に作ったマクロで事件が起きた。

Aさん：「コロ子！大変！！！ファイルが無くなっちゃった！！！」
コロ子：「え！？どうしたんですか？」
Aさん：「間違った入力をしてボタン押したら、ファイルが無くなっちゃったの！」

え！？そんな事ある？？
確認してみると、フォルダ内にあるはずのファイルが消えている。
コードを見てもファイル削除の処理は入っていない。
ファイルが無くなったのはマクロのせいじゃないよ、と思いながらフォルダの中に適当なファイルを入れて同じように実行してみたら、ファイルが消えている！
ファイル削除の処理は入ってないのに！何で！？

どうやら
入力が間違っていたことが原因でファイル名が取れず、ファイル名が空の状態でファイルオープンするとエラーが起こり（これは当然）、そしてフォルダ名の配下のファイルが削除される、らしい。
更に、削除されるファイルとそうでないファイルがある。

Dim fileName As String

fileName = ファイル名を取得する処理　←何らかの原因で””（空）が入る

Workbooks.Open フォルダ名 & "\" & fileName　←ファイル名が空で開く

原因究明のために自分のPCに同じような環境を作ってマクロを実行してもファイルが消えない。
どうやっても再現できない。

分かった事

①ファイル名が空("")でWorkbooks.Openを実行するとパス配下のファイルが削除される
②ネットワーク上で起こる（ローカル環境では起こらない）
③ファイル名の先頭文字がアルファベットのものは削除されない

確かに雑なマクロを作ったコロ子が悪い。
でもファイルが削除されるなんて酷過ぎる！Workbooks.Openでファイルが削除されるなんてどこにも書いてないよ！
たまたま重要なファイルがアルファベットから始まっていたので今回は助かった。でもそうじゃなかったら本当にヤバイ！！
これって、本当に死んじゃうやつだよ！

Microsoftさん、こんなのありですか！！！！

使うの自分だけだからとか、限られたグループで使うだけだからエラーが出てもまあいいや、みたいな作り方してると超危険。
必ず、ファイル名がある事を確認してからファイルを開くべし！

Dim fileName As String

fileName = ファイル名を取得する処理

If fileName <> "" Then

    Workbooks.Open フォルダ名 & "\" & fileName
    
End If

1年を振り返る（ノンプロ犬、エセプロ犬になる）

こんにちは。
派犬事務員のコロ子です。

今年もノンプロ研アドベントカレンダーに参加しました！
この記事は「ノンプロ研 Advent Calendar 2020」の3日目です。

adventar.org

今年は「派犬事務員」として大きな転機があった。
18年間所属した部署から新しい部署に異動になった。

異動の経緯

実は「辞める」と言った事が発端だった。

仕事や会社に不満というより（いやいやめっちゃ不満あったけど）、18年勤めて派犬という立場ではもうこれ以上どうにもならないと思った。
このままずーっと派犬のままなのか。何も変わらず、このまま一生この会社に飼われるのか。
そんなの嫌だ。派犬、派犬、派犬って毎日犬扱い（犬だけど）にはもううんざりだ。
もう嫌だ！！もう辞める！
次は決まってないけど、別れなければ出会いはない！！
勢いよく飛び出した。
つもりだった。

所長（以前上司だった）：「コロ子、辞めるんだって？」
コロ子：「はい。長い事お世話になりました。」
所長：「次はどうするの？」
コロ子：「・・・まだ決まってません・・・」
所長：「まだ次決まってないなら、コロ子に頼みたい仕事があるんだけど。」
と言って分厚いファイルを見せてくれた。
所長：「こういうのアナログに手作業でやっていて大変なんだ。なんとか上手いことシステム化できないか考えてくれないか？外注するのも大変なんだ。他にもこういうの沢山あるんだ。」

えっ。本当に？
そういうの考えるの好き。面白そう。
でも、できるかな？できるかも？やってみたい！

あっけなく元さやに戻る。

一人部署

ということで部署異動で、総務の一角に机を置くことになった。
総務だからいろんな人が来る。
「あれ？コロ子何でここにいるの？えっ？異動？マジで？何で何で？前の部署イヤになっちゃったの？」
前の部署イヤになったのバレてる・・・。
一度辞める宣言しちゃった後だから気まずい。
総務にいるのに総務の仕事できない役立たず感が半端ない。めっちゃ浮いてる状態で新しい仕事は始まった。

なぜかモチベーションが下がる

コードを書いている時は楽しい。以前のようなルーチンワークを持っていないので集中して作れる。憧れのVBA三昧。
しかし、以前も孤独に悩んでいたけど、結局は一人部署なので誰も相談できる人がいない。
ノンプロ研で相談できるけど、具体的な仕事の内容はなかなか相談できない。
行き詰るとそこから一歩も進まなくなる。
また、「ここはどうしますか？」とメールをしても、なかなか返事が返ってこない。微妙な待ち時間が多い。
空いた時間に勉強しようと本を見るも、授業中に隠れて漫画を読んでるみたいな気分になって落ち着かない。

エセプロになった事が原因か？

理想の環境のはずなのに毎日モヤモヤ。精神的な疲労が続く。
今までは事務仕事でお給料を貰っていた。
異動になってからは「こーゆーの作って」を作る事が仕事になった。
ということは、
お金を貰う＝プロ
もしかして、プロになってしまったのか？
えっ、どうしよう。
プロとしてやっていけるほどの技量がないのは分かりきっている。
お給料が少ないのに不満がありつつも、プロとしてお金を貰うのはおこがましい。

なんとかしてプロとしてやっていけるほどの技量をつけなければ、と焦れば焦るほど、いろいろ手を出して何もかも中途半端。
いったいこの先どこに向かっているのだろう。目標が見当たらない。自分がどうなりたいのか分からない。
環境変われどやっぱり迷走。

VBA ユーザーフォームの色をオシャレにする

こんにちは。
派犬事務員のコロ子です。

美的センスに全く自信がありません・・・。

上司：「あのさ、コロ子の作るフォームって、なんかダサいんだよね」

コロ子：「・・・ダサい、と言いますと・・・」

上司：「いつも色とかグレーっぽくてイケてないんだよね」

ええっー！フォームの色って気にするところ！？
ってゆーか、そーゆうものじゃないの？？

上司：「もうちょっとオシャレな感じにならない？」

・・・。
でもよく「人は見かけが9割」とか聞くし（心が痛い）やっぱ見た目って大切なのね・・・。そもそもユーザーフォームの色って変えられるのかな？

ユーザーフォームの色を変える

ユーザーフォームのプロパティを見てみると、色は変更できそう。

でも、選べる色が少ない。
もっといろいろな色を選びたい場合はVBAで色指定できる。

'フォームの背景色を指定
UserForm1.BackColor = RGB(0, 0, 0)

'テキストボックスの背景色を指定
UserForm1.TextBox1.BackColor = RGB(0, 0, 0)
'テキストボックスの文字色を指定
UserForm1.TextBox1.ForeColor = RGB(0, 0, 0)

'コンボボックスの背景色を指定
UserForm1.ComboBox1.BackColor = RGB(0, 0, 0)
'コンボボックスの文字色を指定
UserForm1.ComboBox1.ForeColor = RGB(0, 0, 0)

'コマンドボタンの背景色を指定
UserForm1.CommandButton1 = RGB(0, 0, 0)
'コマンドボタンの文字色を指定
UserForm1.CommandButton1 = RGB(0, 0, 0)

これなら思い通りの色にできるぞ！
と意気込んだところで、そもそもの色のセンスが悪いので配色がおかしい。
やればやるほどダサくなる。
色にも迷走、疲弊したところにこれにたどり着いた。

デザイン本。オシャレな配色のパターンがいっぱい載ってる！
最初からこーゆーの見れば良かったなー。これならオシャレなフォームが作れる！
しかし、世の中そんなに甘くない。いっぱいありすぎて選べない。
フォームにふさわしい配色が分からない。
それでも自分で配色するより100倍マシなので、これと思うものをチョイス。

早速、こんなユーザーフォームで試してみる。

コロ子がチョイスしたのは、カーキ、茶色、オレンジ、黒。
UserForm1.BackColor = RGB(0, 0, 0)
と直接RGB値を指定すると、色々試している間にどの色を指定しているか分からなくなってしまう。思考錯誤用に指定の色のRGB値を戻すモジュールを作成する。

【色モジュール】標準モジュール

Function カーキ() As Long

    Dim R As Long
    Dim G As Long
    Dim B As Long

    R = 237
    G = 186
    B = 98
    
    カーキ = R + G * 256 + B * 256 * 256

End Function

Function オレンジ() As Long

    Dim R As Long
    Dim G As Long
    Dim B As Long

    R = 221
    G = 115
    B = 41
    
    オレンジ = R + G * 256 + B * 256 * 256

End Function

Function 茶色() As Long

    Dim R As Long
    Dim G As Long
    Dim B As Long

    R = 118
    G = 85
    B = 52
    
    茶色 = R + G * 256 + B * 256 * 256

End Function

Function 黒() As Long

    Dim R As Long
    Dim G As Long
    Dim B As Long

    R = 0
    G = 0
    B = 0
    
    黒 = R + G * 256 + B * 256 * 256

End Function

RGB値は
赤の数値 + 緑の数値×256 + 青の数値×256×256
で計算できる。

上記の色を使ってフォームの色を変更する。
【シート1モジュール】

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

Load UserForm1

With UserForm1

    With .TextBox1
        .BackColor = 色.黒
        .ForeColor = 色.カーキ
    End With

    With .ComboBox1
        .BackColor = 色.黒
        .ForeColor = 色.カーキ
    End With

    With .CommandButton1
        .BackColor = 色.黒
        .ForeColor = 色.カーキ
    End With

    .BackColor = 色.茶色

    .Show

End With

End Sub

こんな感じになった。

ちょっと良く分からないので、いろいろ作って比較してみよう。

ユーザーフォームをコピーする

①UserForm1を選択して、Ctl+A(全て選択)、Ctr+C(コピー)
②新規にユーザーフォームを挿入してフォーム上でCtr＋V(ペースト)

この方法でもコピーできるけど、フォームのサイズや、各コントロールのマクロはコピーされないので、次の方法がおススメ。

①ユーザーフォームをエクスポートする。
　（フォームの場合はドラッグ＆ドロップはできない。）
・UserForm1.frm
・UserForm1.frx
の2つのファイルが作成される。
　

②元のユーザーフォームの名前を変更する
　UserForm1　→　UserForm2　へ変更
　

③　①で作成したUserForm1.frmをインポートする。

ユーザーフォームを比較する

ユーザーフォームをコピーできたので3っつくらい作って比較してみる。

【シート1モジュール】

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)


Load UserForm1

With UserForm1

    With .TextBox1
        .BackColor = 色.黒
        .ForeColor = 色.カーキ
    End With

    With .ComboBox1
        .BackColor = 色.黒
        .ForeColor = 色.カーキ
    End With

    With .CommandButton1
        .BackColor = 色.黒
        .ForeColor = 色.カーキ
    End With

    .BackColor = 色.茶色

    .StartUpPosition = 0
    .Top = 200
    .Left = 100

    .Show vbModeless
    
End With

'******************************************************

Load UserForm2
With UserForm2

    With .TextBox1
        .BackColor = 色.カーキ
        .ForeColor = 色.黒
    End With
      
    With .ComboBox1    
        .BackColor = 色.カーキ
        .ForeColor = 色.黒    
    End With
        
    With .CommandButton1  
        .BackColor = 色.カーキ
        .ForeColor = 色.黒  
    End With

    .BackColor = 色.オレンジ
    
    .StartUpPosition = 0
    .Top = 200
    .Left = 400
    
    .Show vbModeless
    
End With

'******************************************************

Load UserForm3
With UserForm3

    With .TextBox1   
        .BackColor = 色.茶色
        .ForeColor = 色.オレンジ    
    End With    
    
    With .ComboBox1  
        .BackColor = 色.茶色
        .ForeColor = 色.オレンジ    
    End With
        
    With .CommandButton1  
        .BackColor = 色.茶色
        .ForeColor = 色.オレンジ    
    End With

    .BackColor = 色.カーキ
    
    .StartUpPosition = 0
    .Top = 200
    .Left = 700
    
    .Show vbModeless
    
End With

End Sub

ポイント①
3つのフォームを並べて比較したいので、モードレスで表示する。
オブジェクト.Show vbModeless
モードレスにしないと表示されているフォームを閉じないと次のフォームが表示されないので並べて比較できない。

ポイント②
並べて表示させるために、位置指定をする
.StartUpPosition = フォームを最初に表示する時の位置（0は指定なし）
.Top = フォームの上端の位置
.Left = フォームの左端の位置

3つ並べて表示して比較してみる。

えっ！
どれもイマイチですって！！！

やっぱり付け焼き刃じゃダメかぁ～。

おススメのユーザーフォームの配色があったら教えてください！

VBA モジュールを再利用

こんにちは。
派犬事務員のコロ子です。

今更ながら、いつも書いているおなじみの処理の専用モジュールを作れば再利用できる事に気が付いた。本当に今更ながら・・・。

例えば、いつも使う計算式・係数・定数。オリジナルの表記。いろいろあるけど、特に毎回面倒なのがセルの色。
Rangeオブジェクト.Interior.Color がどうしても覚えられない。
Rangeオブジェクト.まで打って何だっけ～、と思いながらインテリセンス表示を2往復くらいして、結局分からなくてネット検索。
更にRGB値も「セルに色を付ける。ホームタブ→塗りつぶしの色→その他の色→ユーザー設定」で毎回調べている。そしてグレートバリアリーフ（GBR）への強い憧れなのか、毎回RGBをGBRと書いてしまう。

セルに色を付ける処理って、そこそこある。
それなのに毎回これって効率悪すぎ！！

それで今更ながらセルの色を付ける専用モジュールを作って保存しておけばいいことに気が付いた。

セルに色を付ける専用モジュールを作る

①標準モジュールに色モジュールを作成する

②色モジュールに、いつも使う色を設定するプロシージャーを作成する。

Sub 黄色(ran As Range)
    ran.Interior.Color = RGB(255, 255, 0)
End Sub

Sub 赤(ran As Range)
    ran.Interior.Color = RGB(255, 0, 0)
End Sub

Sub グレー(ran As Range)
    ran.Interior.Color = RGB(191, 191, 191)
End Sub

Sub ピンク(ran As Range)
    ran.Interior.Color = RGB(255, 153, 255)
End Sub

③モジュールをエクスポートする
色モジュールで右クリックして「ファイルのエクスポート」を選択する。

④色.basファイルとして保存する
C:\Users\***\AppData\Roaming\Microsoft\AddIns　がデフォルトになっているけど、階層が深くて探しに行くのが面倒なので、デスクトップなどにモジュールフォルダを作成して、そこに保存してもいいかも。

色.basファイルができる。

⑤再利用する（モジュールをインポートする）
セルに色を付ける処理が使いたくなったら、色.basファイルをインポートする。
プロジェクトエクスプローラーで右クリックして「ファイルのインポート」を選択する。

もしくはドラッグ＆ドロップでもOK。

【例】A1セルをピンクにする

Call 色.ピンク(Range("A1"))

完成！

あと、既存のセルの色を調べるプロシージャー、調べた色を使うプロシージャー、色を消すプロシージャーとかも便利。

Sub 色調べる(ran As Range)
    Debug.Print ran.Interior.Color
End Sub

Sub 色付ける(ran As Range, myColor As Long)
'myColorには「色調べる」でイミディエイトウインドウに表示された数値を指定する
    ran.Interior.Color = myColor
End Sub

Sub 色消す(ran As Range)
    ran.Interior.Color = xlNone
End Sub

これを作ってからセルに色を付ける処理がサクサクできて楽しくなった。
いろいろなオリジナルモジュールを作ってコレクションすると楽しい。

VBA シート指定攻防戦

こんにちは。
派犬事務員のコロ子です。

シートの指定方法

シートの指定方法って悩む。

①シート名で指定
　Worksheets("シート名").Range("A1").Value

②位置で指定
　Worksheets(1).Range("A1").Value

③オブジェクト指定
　Sheet1.Range("A1").Value

簡単だからなんとなくいつもオブジェクト指定にしてるけど、シートをコピーして、元のシートを削除されると困る。直すのにはVBEエディタを開かなくちゃいけないから、ユーザーの自力修正はハードルが高い。
やっぱりシート名指定が安全なのか、と思っていたけど・・・。

Aさん：「ちょっと！！！マクロが動かないんだけど！！！」

コロ子：「どうしたんですか？」

Aさん：「昨日まではフツーに動いてたのに。今日突然動かなくなったのよ！」

見てみると、シート名が変更されたいた。

Aさん：「何が原因？またこういう事があると困るから、原因教えてくれる？」

コロ子：「シート名が変更されていたので・・・」

Aさん：「変えてないわよ！」

コロ子：「でも、変わってたから・・・」

Aさん：「変えてないわよ！」

いやいや、変えてるから。コードはシート名指定で書いてて、そのシート名と実際のシート名が違っている。

Aさん：「あっ。そう言えば、一つ心当たりがあるわ。データがいっぱいになってきたら古いデータを別のシートに移したの。コピーしたらダメなの？」

コロ子：「コピーしても大丈夫ですけど、きっとその時にシート名も変えちゃったのかもしれないですね。」

Aさん：「変えてないわよ！」

自覚症状なし。手強い。

シートをよく見てみるとこんな感じ。

どうやら、メインデータは一番左に置いて、古いデータや個別に見たいデータは右側に足していくパターンらしい。そして無意識のうちにシート名を変更することがある。
ということで

・シート名が存在するか確認し、あればシート名指定にする。
・もし存在しなければ、一番左のシートを指定する。

Dim buf As Worksheet
Dim flg As Boolean

'「測定データ」というシート名があるか確認する
For Each buf In Worksheets

    If buf.Name = "測定データ" Then
        flg = True
    End If

Next buf


Dim ws As Worksheet

If flg Then

    '「測定データ」シートがあればシート指定
    Set ws = Worksheets("測定データ")

Else

    'なければ一番左のシートを指定する
    Set ws = Worksheets(1)

End If

これでどう？
若干、心理戦的な感じが危ないかな。まーこれでしばらく様子を見よう。

コロ子：「とりあえず直しましたけど、シート名変えないでくださいね。」

Aさん：「だからっ！変えてないわよ！」

それにしてもWorksheets(1)って位置指定方法、おなじみだけど初めて使った。
こういう時の為の方法なのかな？
シートの指定方法、悩ましい。

VBA 連動したプルダウンを作る ＆ 自動登録

こんにちは。
派犬事務員のコロ子です。

連動したプルダウンリストを作る

ブロック、都道府県、会社名、支店名からできている「店舗情報」シートがある。

この店舗情報を元に、このようなデータを入力したい。

「けっこう入力が大変」と渡された状態ではブロックがプルダウンリストで選択できる。

そして、プルダウンを選択して都道府県を入力しようとすると

選択したブロック以外の都道府県もプルダウンリストに出てしまう。
そして、会社名、支店名はプルダウンリストにするのを諦めたようで手入力になっている。

確かに入力が大変なので「店舗情報」のシートより連動して絞れるプルダウンリストがあるといいかも。

また、店舗情報は随時追加される。

条件としては
①ブロック、都道府県、会社名、支店名がプルダウンリストより選択できるようにする。
②新規の追加ができるようにする。
　・プルダウンリスト以外に手入力ができるようにする。
　・手入力したデータが「店舗情報」シートに追加される。

では、早速作成してみよう。

コード

【Sheet1(データ)モジュール】

'自動登録用に最初のセルの内容を記憶しておく
Private BeforCompany As String
Private BeforBranch As String


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'1行目はタイトル行なので無視する
If Target.Row = 1 Then
    Exit Sub
End If

Dim bloclData As String

'手入力したて出たエラーを無視する
On Error Resume Next

'ブロックの列が選択されたとき
If Target.Column = 2 Then

    bloclData = Sheet2.Block()
    
    'プルダウンリストをリセット
    Target.Validation.Delete
    
    'リストを追加
    Target.Validation.Add Type:=xlValidateList, _
                          Operator:=xlEqual, _
                          AlertStyle:=xlValidAlertWarning, _
                          Formula1:=bloclData

'都道府県の列が選択されたとき
ElseIf Target.Column = 3 Then

    'ブロック名が入っているときのみ
    If Target.Offset(0, -1).Value <> "" Then

        bloclData = Sheet2.Prefectures(Target)
        
        'プルダウンリストをリセット
        Target.Validation.Delete
        
        'リストを追加
        Target.Validation.Add Type:=xlValidateList, _
                              Operator:=xlEqual, _
                              AlertStyle:=xlValidAlertWarning, _
                              Formula1:=bloclData
    
    End If
    
'会社名の列が選択されたとき
ElseIf Target.Column = 4 Then

    '都道府県名が入っているときのみ
    If Target.Offset(0, -1).Value <> "" Then

        bloclData = Sheet2.company(Target)
        
        'プルダウンリストをリセット
        Target.Validation.Delete
        
        'リストを追加
        Target.Validation.Add Type:=xlValidateList, _
                              Operator:=xlEqual, _
                              AlertStyle:=xlValidAlertInformation, _
                              Formula1:=bloclData
    
    End If

'支店名の列が選択されたとき
ElseIf Target.Column = 5 Then

    'データ追加の為に記憶しておく
    If Target.Value <> "" Then
    
        BeforCompany = Target.Offset(0, -1)
        BeforBranch = Target.Value
    
    End If


    '都道府県名、会社名が入っているとき
    If Target.Offset(0, -1).Value <> "" And Target.Offset(0, -2).Value <> "" Then

        bloclData = Sheet2.branch(Target)
        
        'プルダウンリストをリセット
        Target.Validation.Delete
        
        'リストを追加
        Target.Validation.Add Type:=xlValidateList, _
                              Operator:=xlEqual, _
                              AlertStyle:=xlValidAlertInformation, _
                              Formula1:=bloclData
    
    
    End If
    
'数の列が選択されたとき
ElseIf Target.Column = 6 Then

'店舗情報シートにない会社を登録する

    If Target.Offset(0, -1).Value <> "" Then
    
        Call Sheet2.Add_Data(BeforCompany, BeforBranch, Target.Row)
    
    End If
    
End If

End Sub

【Sheet2(店舗情報)モジュール】

Function Block() As String
'ブロック名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    'ブロック名の重複を確認する
    If dic.Exists(Cells(i, 1).Value) = False Then

        dic.Add Cells(i, 1).Value, i
        str = str & Cells(i, 1).Value & ","
        
    End If

Next i

If str = "" Then
    Block = ""
Else

    '最後の,を取る
    Block = Left(str, Len(str) - 1)

End If

End Function


Function Prefectures(Target As Range) As String
'件名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    'データシートのブロック名と店舗情報のブロック名が同じとき
    If Sheet1.Cells(Target.Row, 2).Value = Cells(i, 1).Value Then

        '都道府県名の重複を確認する
        If dic.Exists(Cells(i, 2).Value) = False Then
    
            dic.Add Cells(i, 2).Value, i
            str = str & Cells(i, 2).Value & ","
    
        End If
    
    End If

Next i


If str = "" Then
    
    Prefectures = ""

Else
    '最後の,を取る
    Prefectures = Left(str, Len(str) - 1)
End If

End Function


Function company(Target As Range) As String
'会社名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    '都道府県が同じとき
    If Sheet1.Cells(Target.Row, 3).Value = Cells(i, 2).Value Then

        '会社名の重複を確認する
        If dic.Exists(Cells(i, 3).Value) = False Then
    
            dic.Add Cells(i, 3).Value, i
            str = str & Cells(i, 3).Value & ","
    
        End If
    
    End If

Next i

If str = "" Then

    company = ""

Else

    '最後の,を取る
    company = Left(str, Len(str) - 1)

End If

End Function


Function branch(Target As Range) As String
'支店名をカンマ(,)で区切った文字列を返す

Dim dic As Dictionary
Set dic = New Dictionary
Dim str As String

Dim i As Long

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row

    'データシートと店舗情報の都道府県と会社名が同じ時
    If Sheet1.Cells(Target.Row, 3).Value = Cells(i, 2).Value And _
       Sheet1.Cells(Target.Row, 4).Value = Cells(i, 3).Value Then

        '支店名の重複を確認する
        If dic.Exists(Cells(i, 4).Value) = False Then
    
            dic.Add Cells(i, 4).Value, i
            str = str & Cells(i, 4).Value & ","
    
        End If
    
    End If

Next i


If str = "" Then

    branch = ""

Else

    '最後の,を取る
    branch = Left(str, Len(str) - 1)

End If

End Function

Sub Add_Data(company As String, branch As String, r As Long)

Dim flg As Boolean
Dim lastRow As Long


lastRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim i As Long
For i = 2 To lastRow

    '会社名と支店名がマッチするものがすでにある場合
    If Cells(i, 3).Value = company And _
       Cells(i, 4).Value = branch Then
    
        flg = True
        Exit For
    
    End If
    
Next i

If flg Then

    '上書き
    Cells(i, 1).Value = Sheet1.Cells(r, 2).Value
    Cells(i, 2).Value = Sheet1.Cells(r, 3).Value
    Cells(i, 3).Value = Sheet1.Cells(r, 4).Value
    Cells(i, 4).Value = Sheet1.Cells(r, 5).Value

Else

    '最終行に追加
    Cells(lastRow + 1, 1).Value = Sheet1.Cells(r, 2).Value
    Cells(lastRow + 1, 2).Value = Sheet1.Cells(r, 3).Value
    Cells(lastRow + 1, 3).Value = Sheet1.Cells(r, 4).Value
    Cells(lastRow + 1, 4).Value = Sheet1.Cells(r, 5).Value


End If

    'ソートする
    With Me.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A1"), Order:=xlAscending
        .SortFields.Add Key:=Range("B1"), Order:=xlAscending
        .SortFields.Add Key:=Range("C1"), Order:=xlAscending
        .SortFields.Add Key:=Range("D1"), Order:=xlAscending
        .SetRange UsedRange
        .Header = xlYes
        .Apply
    End With

End Sub

Sheet1(データ)モジュールでは
Worksheet_SelectionChange イベントでセルの選択が変更されたらマクロを実行する。ちょっとコードが長くなっちゃったけど、どの列が選択されたかを判定している。

ポイントは
リストを追加するValidation.Addメソッドで
AlertStyle:=xlValidAlertWarning
にするとアラートが出て、手入力できる。
また
On Error Resume Nextステートメントで、手入力したときにプルダウンリストが作成できないエラーをスキップする。

Sheet2(店舗情報)モジュールでデータの重複を排除するためにDictionaryオブジェクトを使用した。AddメソッドでKeyにプルダウンリストにするデータ入れてExistsメソッドで重複を確認する。Itemは必要ないけど省略できなかったので、適当にカウンタ変数iを入れた。
もっと良い方法があるのかもしれないけど、Dictionaryオブジェクトしか思いつかなかったので。

新規登録はデータシートの6列目（数の列）が選択されたとき「店舗情報」シートに店舗名と支店名が同じものがなければデータを追加する。また最初に入っている値をモジュール変数に入れて記憶しておけば、データの変更があった時に上書きをする。

完成！連動したプルダウン

選択したブロックの都道府県が選択できる

選択した都道府県の会社が選択できる

選択した会社の視点が選択できる

自動登録

プルダウンリストににない場合は手入力OK

↓
手入力したデータが「店舗情報」シートに追加される

連動したプルダウンはエクセルに詳しい人なら関数でできるかもしれないけど（データを作る手間かVBAを書く手間か）だけど、自動登録はVBAでしかできないから、やっぱりVBAは偉いな～。