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は偉いな～。

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

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

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

こんなコードがあったとして

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

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

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

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

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

直し方

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

直った！！
Dim Rows As Long

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

こんなことあり？

VBA Dirはネストできない？

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

Dirの謎？

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

ある「フォルダA」に下記のようなエクセルファイルがある。

別の「フォルダB」に下記のようなフォルダがある。

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

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

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

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

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

教訓

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

ノンプログラマーの特権？

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

新しい部署での仕事

4月から異動になってそろそろ2ヶ月。何をしているかというと「こーゆーの作って」の頼まれ仕事をしている。
事務仕事のルーチンワークは持たず、毎日VBA三昧。ノンプログラマーとしては最高の環境！？なのかな。

上司から分厚いファイルを渡されて「特にイメージはないんだけど、これをいい感じに作って」と言われて悩む。
う～ん、やっぱりAccess案件かなぁ。Access苦手なんだよなぁ。
最初の何日かはただ資料を眺めるだけで何も進まない。考えがまとまらず、ちょっと作ってはボツ、ちょっと作ってはボツを繰り返す。
本当に成果ゼロ。焦る。
今までは事務仕事を持っていたから、マクロ作成の時間の捻出に苦労したけど、進まなくてもその日の仕事の成果ゼロはなかった。
そしてほんのちょっと中途半端にデータベースについて勉強したせいで、リレーションとか正規化とかを意識して、どこから手を付けていいのか分からなくなった。
焦るばかりで何も進まない。
期日の半分くらいが過ぎて焦りが限界に達し「もう、これ以上は無理！正しいとか間違っているとかどーでもいい！」半ばやけになって作り始めた。
テーブル3個くらい作った時点で上司に「Accessで作ってます」と無意味な中間報告をして無理やり進める。なんとか期日に間に合い、とりあえずOKを貰った。
そして後から「あーしたい、こーしたい」がいろいろ出てきて無理やり後付けで推し進めて、スパゲッティのように複雑にからまりまくった謎のデータ構造に仕上がった。
こんなんで、後々メンテナンスできるのだろうか。
お給料の値上げ交渉どころか、お金貰えるレベルに至っていないことがいたたまれない。
どうすれば良かったのだろう。正解が分からない。

過去を振り返る

そして気になる事がある。
今までもAccessを使っていたけど、リレーションとか正規化とか、そんな事は全く知らず、全然デタラメに作っていた。
前の部署で15年以上前に作ったAccessは今でも普通に使えている。
さらに言えば、みんな毎日使っていて、そのAccessがなければ仕事にならないくらいのメインデータベースだ。
そのデータベースを正しく作り直すとしたらどうだろうか？
リレーションとか正規化とかきちんとしたら、なんか使いにくくなりそうな気がする。
どうやっていいのかさっぱり分からない。
もしかしたらデーターベース的に正しくないから使える物になっているのではないか？
どの辺が正しくないかというと、正規化ななんて知らなかったからもちろん非正規化。
リレーションシップには
一対多
多対多
一対一
があるみたいだけど、どれにも当てはまらない。
強いて言うなら一対一の変則系？
お店とかではないので、よく本に載っている例題が参考にならない。
リレーションシップというより、その部署で働いている人なら誰でも知っている共通認識で繋がっている。でもその部署だけのものなので十分使えている。

もしプロが作るならそうはいかない。
みんなの共通認識をシステムに落とし込まなければならない。
プロなら100％正しく作る事が求められる。
コロ子のAccessは正しくないおかげで
・メインデータないのにサブデータが入力できたり
・本来ユニークなはずのデータが重複できたり
・マスターテーブルにないものが入力できたり
あり得ないことが、意外と融通が利いて便利だったりする。
プロには絶対作れない。

Excelだって表計算ソフトだけど、絵を描く人もいる。
やりたい事が出来れば、使い方が正しいとか間違っているとかは関係ない。
使い方は自由だ。

もしかしたら、
自由な使い方ができるのはノンプログラマーの特権
なのかもしれない。