派遣事務員の迷走

派遣事務員コロ子。会社の犬。顔出しNG。常に迷走している。

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

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

f:id:SNegishi:20201202152311p:plain

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

adventar.org


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

異動の経緯

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

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


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

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

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

一人部署

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

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

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

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

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

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

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

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


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

f:id:SNegishi:20201128212559p:plain

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

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

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

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

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

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

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

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

f:id:SNegishi:20201128212805p:plain

でも、選べる色が少ない。
もっといろいろな色を選びたい場合は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)


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

f:id:SNegishi:20201128215648p:plain

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

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

f:id:SNegishi:20201128220458p:plain

コロ子がチョイスしたのは、カーキ、茶色、オレンジ、黒。
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

こんな感じになった。

f:id:SNegishi:20201128221956p:plain

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

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

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

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

ユーザーフォームをエクスポートする。
 (フォームの場合はドラッグ&ドロップはできない。)
・UserForm1.frm
・UserForm1.frx
の2つのファイルが作成される。
 f:id:SNegishi:20201128223950p:plain


元のユーザーフォームの名前を変更する
 UserForm1 → UserForm2 へ変更
 f:id:SNegishi:20201128224613p:plain


 ①で作成した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つ並べて表示して比較してみる。
f:id:SNegishi:20201128230754p:plain

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

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

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

VBA モジュールを再利用

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

f:id:SNegishi:20201031212631j:plain

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

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

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

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

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


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

f:id:SNegishi:20201031184721p:plain


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

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


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

f:id:SNegishi:20201031185503p:plain


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

f:id:SNegishi:20201031191738p:plain

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


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

f:id:SNegishi:20201031192354p:plain


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

f:id:SNegishi:20201031193238p:plain


【例】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さん:「変えてないわよ!」

自覚症状なし。手強い。

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

f:id:SNegishi:20200926163751p:plain

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

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

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 連動したプルダウンを作る & 自動登録

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

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

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

この店舗情報を元に、このようなデータを入力したい。
f:id:SNegishi:20200830170607p:plain


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


そして、プルダウンを選択して都道府県を入力しようとすると
f:id:SNegishi:20200830171353p:plain

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

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

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

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

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

コード

【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列目(数の列)が選択されたとき「店舗情報」シートに店舗名と支店名が同じものがなければデータを追加する。また最初に入っている値をモジュール変数に入れて記憶しておけば、データの変更があった時に上書きをする。


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

選択したブロックの都道府県が選択できる
f:id:SNegishi:20200830184441p:plain

選択した都道府県の会社が選択できる
f:id:SNegishi:20200830184451p:plain

選択した会社の視点が選択できる
f:id:SNegishi:20200830184517p:plain

自動登録

プルダウンリストににない場合は手入力OK
f:id:SNegishi:20200830184823p:plain


手入力したデータが「店舗情報」シートに追加される
f:id:SNegishi:20200830184909p:plain


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

VBA オブジェクト名を変数名で宣言したら表示がおかしい!

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

オブジェクト名を変数名で宣言したらオブジェクト名の表示がおかしくなった。

こんなコードがあったとして
f:id:SNegishi:20200726233150p:plain

「Rows」というオブジェクト名があるのにもかかわらず、どうしたことか「rowS」という変数名を宣言してしまった。

f:id:SNegishi:20200726233219p:plain

もちろんコンパイルエラー。
「あっ!しまった。VBAって大文字小文字の区別ないんだよね?」
と思ってよく見たら、全ての「Rows」「rowS」に変更されている!!

慌てて
Dim rowS As Long  を
Dim rowA As Long に変更してもオブジェクト名の表示は「rowS」のまま。

f:id:SNegishi:20200726233254p:plain

「えっー!!こんなことあるの???」
他のモジュールを確認しても全て「rowS」になっている。

しかし、表示は「rowS」でおかしいけど、普通に動く。
その後のコードを書くもインテリセンス表示は「Rows」なのに、選択したとたん「rowS」になる。

直し方

「VBEエディタ壊れちゃった・・・」
パソコンを再起動しても直らないし、気持ち悪いけど動くからまぁいいや、と思いかけたとき、ふと思って再度Rowsで宣言してみた。

直った!!
Dim Rows As Long

と書いたとたん、全ての「rowS」が「Rows」に一瞬で変更された。


こんなことあり?

VBA Dirはネストできない?

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

Dirの謎?

先日、こんな依頼があった。

ある「フォルダA」に下記のようなエクセルファイルがある。
f:id:SNegishi:20200619222621p:plain

別の「フォルダB」に下記のようなフォルダがある。
f:id:SNegishi:20200619222711p:plain

フォルダAのエクセルファイルをフォルダBの同じ名前のフォルダに入れたい。
その数500~600個。

Aさん:「急ぎでも必須でもないけど、フォルダの中身を整理したいんだよね。でも手作業でやるのは大変過ぎるんだよね。なんとかならない?」

コロ子:「こんなのなら簡単です。すぐできます!」

めっちゃ安請け合して、1回使うだけだから雑でもいいからささっと作って、ちゃっちゃっと終わらせようとこんなコードを書いてみたところ・・・。

Sub Move_File()

Dim fileName As String
'フォルダAの中のファイル名を取得
fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")

Do While fileName <> ""

    Dim folderName As String
    'フォルダBの中のフォルダ名を取得
    folderName = Dir(ThisWorkbook.Path & "\フォルダB\", vbDirectory)
    
    Do While folderName <> ""
    
        If Left(fileName, 5) = folderName Then
            
            Name ThisWorkbook.Path & "\フォルダA\" & fileName As _
                 ThisWorkbook.Path & "\フォルダB\" & folderName & "\" & fileName
        
        End If
        folderName = Dir()

    Loop
    
    fileName = Dir()

Loop

End Sub

あれ・・・?
上手くいかない。最初の一つしかできてない?

理由が良く分からないので分解して確認してみる。

フォルダA内のファイル名を取得する

Sub test1()

Dim fileName As String

fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")

Do While fileName <> ""

    Debug.Print fileName
    fileName = Dir()

Loop

End Sub

イミディエイトウインドウ

AAA-1-ファイル.xlsx
AAA-2-ファイル.xlsx
AAA-3-ファイル.xlsx
AAA-4-ファイル.xlsx
BBB-1-ファイル.xlsx
BBB-2-ファイル.xlsx
BBB-3-ファイル.xlsx

問題なし。

フォルダBのフォルダ名を取得する

Sub test2()

Dim folderName As String
folderName = Dir(ThisWorkbook.Path & "\フォルダB\", vbDirectory)

Do While folderName <> ""

    Debug.Print folderName
    folderName = Dir()

Loop

End Sub


イミディエイトウインドウ

.
..
AAA-1
AAA-2
AAA-3
AAA-4
BBB-1
BBB-2
BBB-3

これも問題なし。
(「.」は自分自身のフォルダ、「..」は1つ上のフォルダ。Dir(パス, vbDirectory)でフォルダを取得すると「.」と「..」も取得する。)


あとは、疑わしきはファイルの移動
「Name パス\古い名前 As パス\新しい名前」で移動する。
試しに1つやってみる。

Sub test3()

Name ThisWorkbook.Path & "\フォルダA\AAA-1-ファイル.xlsx" As _
     ThisWorkbook.Path & "\フォルダB\AAA-1\AAA-1-ファイル.xlsx"

End Sub

これも問題なし。


でもやっぱりDirが疑わしいので調べたところ

fileName = Dir(パターン)
最初にパターンに一致するファイル(フォルダの名前etc)を文字列で返す。
fileName = Dir()
次にパターンに一致するファイル(フォルダの名前etc)を文字列で返す。

途中で違うパターンを挟んでみると

Sub test4()

Dim fileName As String

'パターンA フォルダAの中身
fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")
Debug.Print fileName

fileName = Dir()
Debug.Print fileName


'途中で別のパターンを挟む
'パターンB フォルダBの中身
Dim folderName As String

folderName = Dir(ThisWorkbook.Path & "\フォルダB\", vbDirectory)
Debug.Print folderName

folderName = Dir()
Debug.Print folderName

folderName = Dir()
Debug.Print folderName

folderName = Dir()
Debug.Print folderName

End Sub

イミディエイトウインドウ

AAA-2-ファイル.xlsx
AAA-3-ファイル.xlsx
.
..
AAA-1
AAA-2

途中でパターンを変えると最初のパターンは上書きされてなくなっちゃう!

それにしてもDirって変な関数、というか奥が深い。

う~ん、こういう場合は諦めてFSO(FileSystemObject)を使うしかないかぁ。
(FSOを使う場合は「Microsoft Scripting Runtime」の参照設定を忘れずに!)

DirとFSOと組み合わせ
一回だけ使う分にはこれで十分。

Sub test5()

'DirとFSOと組み合わせ

Dim fileName As String

'フォルダA中のファイルはDirで取得
fileName = Dir(ThisWorkbook.Path & "\フォルダA\*.xlsx")

Do While fileName <> ""

    'フォルダB中のフォルダはFSOで取得
    Dim fso As FileSystemObject
    Set fso = New FileSystemObject
    
    Dim folderPath As Folder
    Set folderPath = fso.GetFolder(ThisWorkbook.Path & "\フォルダB\")
    
    Dim folderName As Folder
    
    For Each folderName In folderPath.SubFolders

        If Left(fileName, 5) = folderName.Name Then
        
            Name ThisWorkbook.Path & "\フォルダA\" & fileName As folderName & "\" & fileName
            Exit For
        
        End If
    
    Next folderName

    
    fileName = Dir()

Loop


End Sub


統一感を出すために両方FSOを使う場合

Sub test7()

Dim fso As FileSystemObject
Set fso = New FileSystemObject

Dim filePath As Folder
Set filePath = fso.GetFolder(ThisWorkbook.Path & "\フォルダA\")

Dim fileName As File

For Each fileName In filePath.Files

    Dim folderPath As Folder
    Set folderPath = fso.GetFolder(ThisWorkbook.Path & "\フォルダB\") 
    
    Dim folderName As Folder
    
    For Each folderName In folderPath.SubFolders

        If Left(fileName.Name, 5) = folderName.Name Then
        
            Name filePath & "\" & fileName.Name As folderName & "\" & fileName.Name
            Exit For
        
        End If
    
    Next folderName

Next fileName

End Sub

教訓

簡単だと思ったのに、結局つまずいてすぐにできなかった。
「すぐできます」とか言うのはやめるべし!