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

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

Excelで組織図を作成（２）兼任の場合と集計

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

前回書いた「Excelで組織図を作成する」の続き。
組織図を作成した後に、
「○○さんは今年度からA課とB課を兼任することになった」とか
「組織図の下の方に集計の表を載せたい」とか
必ず何か出てくる。
先に言ってくれればいいのに、と思うけど、完成図を見てから思い出すんだろうな、きっと。

兼任の場合は？

例えば、コロ子が第一部のA課とB課を掛け持ちすることになった場合
名簿テーブルのデータを追加する

一覧表に同じ人がダブっているのが気持ち悪く感じるかもしれないけど、こうすればコードはそのままで複数部署に所属できる。

集計

兼任の列を追加して配分を入力。

1÷重複数を計算するマクロを作成したけど
配分が「A部署：B部署＝3：7」とか、3部署掛け持ちで割り切れない、などで結局は手入力。

別シートに集計表を作る

ここでもマクロを作りたくなるけど、関数の方が簡単なのでSUMIFS関数を使う。
第一部、A課、A区分の合計は
=SUMIFS(名簿!$H:$H, 名簿!$F:$F, "第一部", 名簿!$G:$G, "A課", 名簿!$D:$D, "A")

集計表を張り付け

この集計表を図として貼り付けする

表をコピーする

組織図の図を貼りたい位置で右クリックして
「その他の貼り付けオプション」→「リンクされた図」を選択して張り付ける

集計表も図なので好きな位置に移動できる。

図のプロパティを
「セルに合わせて移動やサイズを変更しない」にする。

こんなふうに列が増えたり減ったりしても形が崩れない。

Tips

【図形をまとめて選択する。】

「ホームタブ」→「検索と選択」→「オブジェクトの選択」

マウスでドラッグした範囲の図形が選択される。

まとめて移動する時に便利！

【図形の位置を揃える】

位置を揃えたい図形を選択して
「書式タブ」→「配置」より図形の位置を揃えられる

Excelで組織図を作成

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

4月は部署異動の時期ですね。（もう5月になっちゃったけど）
コロ子もこの4月からから新しい部署に異動になった。
今年は異動も多く、新しい部署ができたりかなり大胆な組織変更があった。
そこで上司から「組織図を簡単に作れるようなツールを作って」の依頼がきた。
現行はエクセル方眼紙で作成していて、変更がある度に、コピーしたりセルを結合したり、修正に手間がかかっている。

マクロを作るにあたって、セルに書き込むタイプだと形を整えるのが大変なので、セルの代わりに図形にして、好きな位置に置く事にした。
【完成図】

項目は図形なので、イレギュラーな場合でも自由に移動できる。
例えば、後から「こんな風にしたい」とか言われても対応OK。

下準備

別のシートに社員の一覧表を作成する。

こんな感じで必要な項目を一覧表にしてテーブルにする。
表にカーソルを置いて「Ctr＋T」でテーブルに変更できる。
テーブル名は「名簿テーブル」とした。
テーブルは最近のお気に入り。

コード

まずは図形の上位置と高さを決める。これと思う数字を入れて後で調整する。
名簿テーブルの列番号もEnuｍにする。

'図形の位置上側*******************
Const POSITION1 As Long = 70 '事業部長
Const POSITION2 As Long = 180 '部長
Const POSITION3 As Long = 300 '課長
Const POSITION4 As Long = 360 '課員

'図形の高さ***********************
Const HEIGHT1 As Long = 60 '管理職用
Const HEIGHT2 As Long = 20 '一般職用


'名簿テーブルの列
Enum colname

    c_Id = 1
    c_Name
    c_Gender
    c_Employ
    c_Position
    c_bu
    c_Ka
    c_Count

End Enum

名簿テーブルより図形を作成する。
ちょっとややこしいけどポイントは
Dictionaryオブジェクトで部＋課をキーにして部署ごとに要素を作成する。
アイテムを配列（Collectionオブジェクト）にして部署のメンバーの情報（名簿テーブルの行）を入れる。

【クラスモジュール：PersonData】

Private person As Collection

Sub init(lst As ListRow)

    Set person = New Collection
    person.Add lst

End Sub

Sub Add_dic(lst As ListRow)

    person.Add lst
    
End Sub

Public Property Get GetPersonData() As Collection

   Set GetPersonData = person

End Property

【標準モジュール】
名簿テーブル：Sheet1
組織図：Sheet3
に作成。

'Dictionaryオブジェクトの参照設定(Microsoft Scripting Runtime)忘れずに！

Sub Organizational_Chart()

Application.ScreenUpdating = True


Dim teamDic As Dictionary
Set teamDic = New Dictionary

Dim lst As ListObject
Set lst = Sheet1.ListObjects("名簿テーブル")

Dim ran As ListRow
Dim Kanrisyoku() As ListRow　 '事業部長と部長
Dim i As Long

For Each ran In lst.ListRows

    If ran.Range(c_Ka) <> "" Then
    
        '部と課の組み合わせをキーとする
        Dim dickey As String
        dickey = ran.Range(c_bu) & ran.Range(c_Ka)
        
        
        If teamDic.Exists(dickey) Then
        
            Call teamDic.Item(dickey).Add_dic(ran)
                   
        Else
        
            teamDic.Add dickey, New PersonData
            Call teamDic.Item(dickey).init(ran)
        
        End If
        
    Else
    
        ReDim Preserve Kanrisyoku(i)
        Set Kanrisyoku(i) = ran
        i = i + 1

    End If

Next ran



'人ごとに図形を作成する
Dim place As Long

Dim buf As Variant
For Each buf In teamDic.Keys

    Call MakeShape(teamDic.Item(buf).GetPersonData, place)
    place = place + 1

Next buf


'事業部長、部長を作成
Call SapeKanrisyoku(teamDic, Kanrisyoku)

Application.ScreenUpdating = True

End Sub

図形の位置とテキストを作成する

Sub MakeShape(coll As Collection, place As Long)

Dim left As Long
Dim top As Long

Dim c As Long
c = POSITION4  '一般職員用トップの位置

Dim i As Long
For i = 1 To coll.Count

    With coll(i)
    
        '左位置の調整
        left = 50 + (100 + 50) * place
        
        Dim height As Long
        height = HEIGHT2
        
        '上位置の調整
        top = GetTop(c, .Range(c_Position), height)
        
        
         '表示名
        Dim nameText As String
        nameText = MakeTaxtName(.Range(c_Name), .Range(c_Ka), .Range(c_Position), .Range(c_Employ))
    
    End With
    
    Call ShapeAdd(nameText, coll(i).Range(c_Employ), left, top, height)

Next i

End Sub

'表示名を作成
Function MakeTaxtName(name As String, Section As String, Position As String, emp As String) As String

    If Position <> "" Then
            
        MakeTaxtName = Section & vbCrLf & name & vbCrLf & Position & "  (" & emp & ")"
        
    Else

        MakeTaxtName = name & "  (" & emp & ")"
    
    End If

End Function

'図形の上位置をセットする
Function GetTop(ByRef c As Long, Position As String, ByRef height As Long) As Long

If Position = "課長" Then

    GetTop = POSITION3
    height = HEIGHT1

Else '一般職員

    GetTop = c
    c = c + 20
    height = 20

End If

End Function

図形を作成（プロパティをセットする）

Sub ShapeAdd(nameText As String, Employ As String, left As Long, top As Long, height As Long)

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

  With Sheet3.Shapes.AddShape _
   (msoShapeRectangle, left, top, 100, height) '図形のタイプ、左位置、上の位置、幅、高さ

    '表示文字の指定
    .TextFrame.Characters.Text = nameText
    .TextFrame.Characters.Font.Size = 10.5
    
    '図形内テキストのフォントカラーを指定する
    .TextFrame.Characters.Font.Color = RGB(0, 0, 0)
    
    '図形内のテキスト水平方向を中央位置にする
    .TextFrame.HorizontalAlignment = xlHAlignCenter
    
    '図形内のテキスト縦方向を中央位置にする
    .TextFrame.VerticalAlignment = xlVAlignCenter

    Call MakeRGB(Employ, R, G, B)

    '図形の枠線の色を指定する
    .Line.ForeColor.RGB = RGB(0, 0, 0)
    .Line.Weight = 1

    '図形の塗りつぶし色を指定する
    .Fill.ForeColor.RGB = RGB(R, G, B)
    
    'セルに合わせて移動するがサイズ変更はしない
    .Placement = xlMove

  End With

End Sub

'雇用区分ごとに図形の色をセットする
Sub MakeRGB(ByVal Employ As String, R As Long, ByRef G As Long, ByRef B As Long)

Select Case Employ

    Case "A"
    
        R = 204
        G = 255
        B = 255
    
    Case "B"
    
        R = 255
        G = 255
        B = 153
    
    Case "C"
    
        R = 153
        G = 204
        B = 255
     
    
    Case "犬"
    
        R = 146
        G = 208
        B = 80
    
  
End Select

End Sub

管理職（事業部長、部長）用の図形を作成する
位置合わせは力ずく。（上手くできなければ後で移動してもOK)

Sub SapeKanrisyoku(teamDic As Dictionary, Kanrisyoku() As ListRow)


Dim left1 As Long
Dim left2 As Long
Dim top As Long
Dim height As Long
Dim nameText As String

Dim ran As Variant

For Each ran In Kanrisyoku()

    nameText = MakeTaxtName(ran.Range(c_Name), ran.Range(c_bu), ran.Range(c_Position), ran.Range(c_Employ))
    height = HEIGHT1
    

    If ran.Range(c_Position) = "事業部長" Then
    
        top = POSITION1
        left1 = (50 + (100 + 50) * teamDic.Count + 100) / 2 - 50 - 50
        Call ShapeAdd(nameText, ran.Range(c_Employ), left1, top, height)
        

    ElseIf ran.Range(c_Position) = "部長" Then
    
        top = POSITION2
        
        Dim buf As Variant
        Dim cnt As Long
        For Each buf In teamDic.Keys
        
            If InStr(buf, ran.Range(c_bu)) <> 0 Then
            
                cnt = cnt + 1
            
            End If
        
        Next buf
        
        left2 = left2 + 50 + ((100 + 50) * cnt - 50) / 2 - 50

        Call ShapeAdd(nameText, ran.Range(c_Employ), left2, top, height)
        
        left2 = (100 + 50) * cnt
        cnt = 0
        
    End If
        
Next ran


End Sub

【図形の初期化】
図形を作成した後に引いた線はそのままにしたいので、Rectangle（図形）とPicture（後で作成する集計の表）のみを削除

Sub DelShape()

Application.ScreenUpdating = False

Dim shp As Shape

For Each shp In Sheet3.Shapes

    If InStr(shp.name, "Rectangle") <> 0 Or InStr(shp.name, "Picture") <> 0 Then
    
        shp.Delete
    
    End If
 
Next shp

Application.ScreenUpdating = True

End Sub

図形の作成は出来たので、ボタンを作成して下記コードを登録すれば完成！

Sub Main()
    
    Call DelShape
    
    Call Organizational_Chart
    
End Sub

線はマクロで作るの大変なので手作業でお願いします！

追加

クラスモジュールの挿入の仕方

「クラスモジュール：PersonData」はクラスモジュールのコードを書いてください。
新規のクラスモジュールを追加します。
挿入→クラスモジュール

クラスモジュールのオブジェクト名を変更します。
「Class1」→「PersonData」
オブジェクト名はプロパティウインドウから変更できます。

コロ子勘違いしていた インスタンスの生成

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

クラスのインスタンスの生成でちょっと気になる事がある。
ループをしながらDictionaryオブジェクト（Collection オブジェクトでも）のアイテムにクラス型のオブジェクトを追加する場合、ループの中でインスタンスを生成しているコードをよく見かける。

【例】
クラスモジュール：Class1

Public data As Long

'標準モジュール

Sub Test1()

Dim dic As Dictionary
Set dic = New Dictionary

Dim i As Long

For i = 1 To 3

    Dim dicitem As Class1
    Set dicitem = New Class1
    
    Dim dickey As String
    dickey = "キー" & i
    
    dicitem.data = i * 2
    
    dic.Add dickey, dicitem

Next i


Dim j As Variant
For Each j In dic.Keys

    Debug.Print dic.Item(j).data

Next j

End Sub

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

2
4
6

結果は正しいけど、なんか納得できない。
なんでループの中でインスタンスを生成しているのだろう？

次のコードTest2、Test3を見ると

Sub Test2()

Dim dic As Dictionary
Set dic = New Dictionary

Dim dicitem As Long

Dim i As Long

For i = 1 To 3

    Dim dickey As String
    dickey = "キー" & i

    dicitem = i * 2
    
    dic.Add dickey, dicitem

Next i


Dim j As Variant
For Each j In dic.Keys

    Debug.Print dic.Item(j)

Next j

End Sub

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

2
4
6

test2で、DictionaryオブジェクトのアイテムにLong型の変数を入れると値渡ししているように思える。

Sub Test3()

Dim dic As Dictionary
Set dic = New Dictionary

'先にインスタンスを生成する
Dim dicitem As Class1
Set dicitem = New Class1

Dim i As Long

For i = 1 To 3

    Dim dickey As String
    dickey = "キー" & i
    
    dicitem.data = i * 2
     
    dic.Add dickey, dicitem

Next i


Dim j As Variant
For Each j In dic.Keys

    Debug.Print dic.Item(j).data

Next j

End Sub

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

6
6
6

でもtest3では参照渡ししているように思える。
ということはtest1では同じ変数名で何度もインスタンスを生成しているということなの？？
混乱。

仕方ないのでノンプロ研で質問してみたところ、コロ子、インスタンスの生成について分かっていなかったことが判明。

【分かった事】
①オブジェクト型の変数には参照先が格納される。
なのでTest3ではDictionaryオブジェクトのキー1～3のアイテムには同じインスタンスが格納されている。

②New クラス名でいくつでもインスタンスを生成できる。
Dim 変数名 As クラス名
Set 変数名 = New クラス名
はセットで1変数1インスタンスだと思っていた。
「New クラス名でインスタンスを生成できる」は耳にタコができるほど聞いていたのに・・・。
Dim 変数名 As クラス名　でクラス型の変数を宣言
Set 変数名 = New クラス名　で生成したインスタンスを変数に格納するという意味だった！

Dim A As Class1
Set A = New Class1
Set A = New Class1

と書いたら、2行目のAと3行目のAには別のインスタンスが格納されている。

変数宣言はループ中に書いたら1度しか処理されないのと同じで、
Set 変数名 = New クラス名も1度しか処理されないのかと思っていた！

ちなみに次のように書くとクラス型変数の宣言が不要。

'--省略--
Dim dicKey As String
For i = 1 To 3
    dicKey = "キー" & i
    dic.Add dicKey, New Class1
    dic.Item(dicKey).data = i * 2
Next i
'--省略--

そーゆーことなのね！！

ということは、前回の記事で書いたコードはクラス型のオブジェクトを配列にしたりして、普通に分かっている人からしたら意味不明なんだろうな・・・。

クラスモジュール、シートモジュールは前回のまま
標準モジュールのみ書き直し。

Public Sub Aggregate()

Dim list As ListObject
Set list = Sheet1.ListObjects(1)

Dim ran As ListRow

Dim dic As Dictionary
Set dic = New Dictionary

Dim i As Long

'データ読み込み
For Each ran In list.ListRows

    Dim dickye As String
    dickye = Sheet1.Key(ran)
    
    If dic.Exists(dickye) Then
        'すでにkeyが存在している時は、
        Call dic.Item(dickye).Add(ran)
        
    Else
    
        'keyが存在しない(初めて)時は、
        'Dicにクラス(RawData)型のオブジェクトを格納
        
        dic.Add dickye, New RawData
        Call dic.Item(dickye).Init(ran)
        
        i = i + 1
        
    End If

Next ran

Call Sheet2.Del


'データ書き出し
i = 2
Dim j As Variant
For Each j In dic.Keys

    Sheet2.Cells(i, cnNo).Value = dic.Item(j).No
    Sheet2.Cells(i, cnLot).Value = dic.Item(j).Lot
    Sheet2.Cells(i, cnData1).Value = dic.Item(j).data1
    Sheet2.Cells(i, cnData2).Value = dic.Item(j).data2
    Sheet2.Cells(i, cnData3).Value = dic.Item(j).Data3
    
    i = i + 1
    
Next j

Call Sheet2.MakeStyle
Sheet2.Activate

End Sub

インスタンスの生成、完全に理解した！（←こーゆーのが一番怪しい）

久々のVBA ノンプロ研中級講座の内容を活かす?

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

実は去年12月にノンプロ研中級講座が終わってから、全くVBAを書いていなかった。
4月から部署を異動するので、ルーチン業務から外れ毎日雑用の日々。
最近はPython（GASにも）に気を取られてVBAはもうしばらくいいかなー、気分になっていた。

そんなダラダラした気分のところに上司から「マクロ作って」の依頼がきた。
VBAもういいや、な気分だったのに、話を聞いたらノンプロ研中級講座の内容がめちゃめちゃ使えそうだったから、少し気分が乗ってきた。

しかし、3ヶ月VBAをやってなかっただけなのに、関数の外にコード書いたり、変数を宣言するのを忘れたり、もうVBA忘れちゃったのかものひどい有り様だった。

ゆっくり良く考えてかっこいいコードが書きたかったけど、「急ぎ」だったので、とりあえず急いで作った。もっといい方法がないか今日考えたけど、時間があるからといっていいアイデア浮かぶわけでもない・・・。
でもノンプロ研中級講座の内容を盛り込めたと思う。

【内容】
下記のようなデータを番号、Lotが同じもので集計する。
データ1、データ2、データ3は各々最大値と最小値を除いて平均する。

表をテーブルにする。

表の中にカーソルを置いて「Ctrl＋T」を押すとテーブルになる！

色が付いてオシャレになっただけじゃない。
テーブルにすると表をオブジェクトとして扱えるから便利。

考え方

①表の「番号」と「Lot」を繋げた文字列をキーにする。
【例】
2行目の場合は「BBBabc」がキー

②表の1行分のデータを格納するクラスを用意する。

③表を1行づつ読み込んで、Dictionaryオブジェクトに格納する
Key：①で作成したキー
Item：②のクラスを配列にして、配列のインデックス番号

Dictionaryオブジェクトに格納する際、Keyがすでに存在していたら、そのインデックス番号のクラスのデータを集計する。

コード

クラスモジュール　RawDataクラス

Private no_ As String
Private lot_ As String
Private data1_ As Long
Private data2_ As Long
Private data3_ As Long
Private max1_ As Long
Private min1_ As Long
Private max2_ As Long
Private min2_ As Long
Private max3_ As Long
Private min3_ As Long
Private cnt_ As Long

'*初回の値をセット
Public Sub Init(ByVal list As ListRow)

    no_ = list.Range(cnNo)
    lot_ = list.Range(cnLot)
    
    data1_ = list.Range(cnData1)
    max1_ = data1_
    min1_ = data1_
    
    data2_ = list.Range(cnData2)
    max2_ = data2_
    min2_ = data2_
    
    data3_ = list.Range(cnData3)
    max3_ = data3_
    min3_ = data3_
    
    cnt_ = 1

End Sub


'*加算
Public Sub Add(ByVal list As ListRow)

    data1_ = data1_ + list.Range(cnData1)
    Call MaxMin(max1_, min1_, list.Range(cnData1))
    
    data2_ = data2_ + list.Range(cnData2)
    Call MaxMin(max2_, min2_, list.Range(cnData2))
    
    data3_ = data3_ + list.Range(cnData3)
    Call MaxMin(max3_, min3_, list.Range(cnData3))
    
    cnt_ = cnt_ + 1

End Sub

'最大値と最小値を探す
'(max, minはByRefにして変数の中身を置き換える）
Public Sub MaxMin(ByRef max As Long, ByRef min As Long, ByVal Data As Long)

    If Data > max Then
        max = Data
    ElseIf Data < min Then
        min = Data
    End If

End Sub


'番号
Public Property Get No() As String

    No = no_

End Property

'ロット
Public Property Get Lot() As String

    Lot = lot_

End Property

'データ1
Public Property Get Data1() As Long

    Data1 = WorksheetFunction.Round((data1_ - max1_ - min1_) / (cnt_ - 2), 0)

End Property

'データ2
Public Property Get Data2() As Long

    Data2 = WorksheetFunction.Round((data2_ - max2_ - min2_) / (cnt_ - 2), 0)

End Property

'データ3
Public Property Get Data3() As Long

    Data3 = WorksheetFunction.Round((data3_ - max3_ - min3_) / (cnt_ - 2), 0)

End Property

Sheet1モジュール

Public Property Get Key(list As ListRow) As String
    
    Key = list.Range(cnNo) & list.Range(cnLot)

End Property

Sheet2モジュール

Public Sub Del()

    Me.UsedRange.Offset(1, 0).Delete

End Sub

Public Sub MakeStyle()

'罫線
Me.Range("A2").CurrentRegion.Borders.LineStyle = xlContinuous
'ソート
Me.Range("A2").CurrentRegion.Sort Key1:=Range("A1"), _
                                  Order1:=xlAscending, _
                                  Key2:=Range("B1"), _
                                  Order2:=xlAscending, _
                                  Header:=xlYes


End Sub

標準モジュール

参照設定：Microsoft Scripting Runtimeを忘れずに。

Public Enum ColumnName

    cnNo = 1
    cnLot
    cnData1
    cnData2
    cnData3

End Enum

Public Sub Aggregate()

Dim list As ListObject
Set list = Sheet1.ListObjects(1)

Dim ran As ListRow

Dim Dic As Dictionary
Set Dic = New Dictionary

'RawDataクラスは動的配列にする
Dim Data() As RawData
Dim i As Long

'データ読み込み
For Each ran In list.ListRows

        Dim kye As String
        kye = Sheet1.Key(ran)
        
        If Dic.Exists(kye) Then
            'すでにkeyが存在している時は、配列のインデックス番号のデータを加算
            Call Data(Dic.Item(kye)).Add(ran)
            
        Else
        
            'keyが存在しない（初めて）時は、Dicにデータを格納
            ReDim Preserve Data(i)
            Set Data(i) = New RawData
            
            Dic.Add kye, i
            Call Data(i).Init(ran)
            i = i + 1
        End If

Next ran

Call Sheet2.Del

'データ書き出し
For i = 2 To UBound(Data) + 2

    Sheet2.Cells(i, cnNo).Value = Data(i - 2).No
    Sheet2.Cells(i, cnLot).Value = Data(i - 2).Lot
    Sheet2.Cells(i, cnData1).Value = Data(i - 2).Data1
    Sheet2.Cells(i, cnData2).Value = Data(i - 2).Data2
    Sheet2.Cells(i, cnData3).Value = Data(i - 2).Data3

Next i

Call Sheet2.MakeStyle
Sheet2.Activate

End Sub

集計結果

こんな感じで集計。

①シートモジュールを使う
②配列
③クラス
④テーブル
などなど、中級講座の内容。
今だから正直に言うけど、テーブルについては知らなかったし、クラスもちょっと自信なかった。TAじゃなくて受講するレベルだった疑惑があるけど、テーブルもクラスも使って作ったから許して～。