みそじのおじさんのクラス 月修正版http://www.moug.net/faq/viewtopic.php?t=62306

clsContainer.cls

Option Explicit

'***************************************************
'クラス名 clsContainer
'***************************************************

Public Event MaxItemCountOver()

Private WithEvents m_ParentAgent As CParentAgent ' 子から連絡を受ける自分の代理人
Private mMoveItems As clsMoveItems
Private mLabel As MSForms.Label
Private mTitleLabel As MSForms.Label
Public Value As Variant

Private Const cnsTitleHeight        As Single = 18
Private Const cnsTitleForeColor     As Long = vbWhite
Private Const cnsTitleBackColor     As Long = &H800000
Private Const cnsContainerBackColor As Long = vbWhite

Private Sub Class_Initialize()
    Dim itfLink As ILink
    Set mMoveItems = New clsMoveItems
    Set m_ParentAgent = New CParentAgent
    ' 子と親の代理人をリンクさせる
    Set itfLink = mMoveItems
    itfLink.Link m_ParentAgent
End Sub

Private Sub Class_Terminate()
    Debug.Print "clsContainer_Terminate"
    Set mMoveItems = Nothing
    Set mLabel = Nothing
    Set mTitleLabel = Nothing
    Set m_ParentAgent = Nothing
End Sub

Public Sub Init(ByVal Label As MSForms.Label)
    Set mLabel = Label
    With mLabel
        .BackColor = cnsContainerBackColor
        .SpecialEffect = fmSpecialEffectEtched
    End With
End Sub

Public Property Get MoveItems() As clsMoveItems
    Set MoveItems = mMoveItems
End Property

Public Property Get Label() As MSForms.Label
    Set Label = mLabel
End Property

Public Function CreateTitle(ByVal Title As String) As Boolean
    Set mTitleLabel = _
        mLabel.Parent.Controls.Add("Forms.Label.1", "Label" & Title, True)
    With mTitleLabel
        .Caption = Title
        .Left = mLabel.Left
        .Top = mLabel.Top - cnsTitleHeight
        .Height = cnsTitleHeight
        .Width = mLabel.Width
        .SpecialEffect = fmSpecialEffectEtched
        .ForeColor = cnsTitleForeColor
        .BackColor = cnsTitleBackColor
        .TextAlign = fmTextAlignCenter
        .Font.Bold = True
    End With
End Function

Public Property Get Parent() As Object
    Set Parent = mLabel.Parent
End Property

Public Property Get Title() As String
    Title = mTitleLabel.Caption
End Property

Public Property Let Title(ByVal Title As String)
    mTitleLabel.Caption = Title
End Property

Property Get ContainerRect() As Rect
    With mLabel
        ContainerRect.Left = .Left
        ContainerRect.Top = .Top
        ContainerRect.Width = .Width
        ContainerRect.Height = .Height
    End With
End Property

Property Get Name() As Variant
    Name = mLabel.Name
End Property

Public Property Get TitleForeColor() As Long
    TitleForeColor = mTitleLabel.ForeColor
End Property

Public Property Let TitleForeColor(ByVal lngNewColor As Long)
    mTitleLabel.ForeColor = lngNewColor
End Property

Public Property Get TitleBackColor() As Long
    TitleBackColor = mTitleLabel.BackColor
End Property

Public Property Let TitleBackColor(ByVal lngNewColor As Long)
    mTitleLabel.BackColor = lngNewColor
End Property

Public Sub OverLapEffect()
    With mLabel
        .BorderStyle = fmBorderStyleSingle
        .BorderColor = vbBlue
    End With
End Sub

Public Sub UndoOverLapEffect()
    mLabel.SpecialEffect = fmSpecialEffectEtched
End Sub

Public Sub Alert()
    RaiseEvent MaxItemCountOver
End Sub

' 子から連絡があったら、自分の代理人を通して子と連絡をとる
Private Sub m_ParentAgent_OnConnect(Parent As Object)
    Set Parent = Me
End Sub

clsContainers.cls

Option Explicit

'***************************************************
'クラス名 clsContainers
'***************************************************

Private mParent As Object
Private mContainers As Collection

Private Sub Class_Initialize()
    Set mContainers = New Collection
End Sub

Private Sub Class_Terminate()
    Debug.Print "clsContainers_Terminate"
    Set mParent = Nothing
    Set mContainers = Nothing
End Sub

Public Function Add( _
      ByVal Name As String _
    , ByVal Left As Single _
    , ByVal Top As Single _
    , ByVal Height As Single _
    , ByVal Width As Single) As clsContainer
                
    Dim Container As clsContainer
    Dim Label As MSForms.Label
    
    Set Container = New clsContainer
    Set Label = mParent.Controls.Add("Forms.Label.1", Name, True)
    Container.Init Label
    
    With Label
        .Left = Left
        .Top = Top
        .Height = Height
        .Width = Width
        .SpecialEffect = fmSpecialEffectEtched
    End With

    mContainers.Add Container, Name
    Set Add = Container
End Function

Public Property Get Items() As Collection
    Set Items = mContainers
End Property

Public Property Get Item(ByVal Index As Variant) As clsContainer
    On Error GoTo Err_Trap:
         Select Case TypeName(Index)
             Case "Long", "Integer"
                  'CollectionのLBoundは1の為+1
                  Set Item = mContainers(CLng(Index) + 1&)
             Case "String"
                  'フィールド名でアクセス
                  Set Item = mContainers(Index)
         End Select
      On Error GoTo 0
Err_Trap:
End Property

Public Sub OverLapEffect(ByVal TargetContainer As clsContainer)
    Dim Container As clsContainer
        
    For Each Container In mContainers
        If TargetContainer Is Container Then
            Container.OverLapEffect
        Else
            Container.UndoOverLapEffect
        End If
    Next
End Sub

Public Sub UndoOverLapEffect()
    Dim Container As clsContainer
        
    For Each Container In mContainers
        Container.UndoOverLapEffect
    Next
End Sub

Public Property Get Parent() As Object
    Set Parent = mParent
End Property

Public Property Set Parent(Parent As Object)
    Me.Parent = Parent
End Property

Public Property Let Parent(Parent As Object)
    If mParent Is Nothing Then
        Set mParent = Parent
    End If
End Property

clsMoveItem.cls

Option Explicit

'***************************************************
'クラス名 clsMoveItem
'***************************************************

Private WithEvents mLabel As MSForms.Label

Private mCapture As Boolean
Private mValue As Variant
Private mOldPositionRect As Rect

Private Type StructOffsetValue
    x As Single
    y As Single
End Type

Private o As StructOffsetValue
Private Const cnsItemBackColor As Long = vbWhite
Private Const cnsItemForeColor As Long = vbBlue

Public Sub Init(ByVal Label As MSForms.Label)
    Set mLabel = Label
    With mLabel
        .Height = 20
        .Width = 70
        .TextAlign = fmTextAlignCenter
        .ForeColor = cnsItemForeColor
        .BackColor = cnsItemBackColor
        .SpecialEffect = fmSpecialEffectEtched
    End With
End Sub

Private Sub Class_Terminate()
    Debug.Print "clsMoveItem_Terminate"
    Set mLabel = Nothing
End Sub

Private Sub mLabel_MouseDown(ByVal Button As Integer, _
                                 ByVal Shift As Integer, _
                                 ByVal x As Single, _
                                 ByVal y As Single)
    mCapture = True
    With mLabel
        .SpecialEffect = fmSpecialEffectBump
        .BackColor = vbYellow
    End With
    o.x = x
    o.y = y
    OldPositionSet
End Sub

Private Sub mLabel_MouseMove(ByVal Button As Integer, _
                                 ByVal Shift As Integer, _
                                 ByVal x As Single, _
                                 ByVal y As Single)
    If Not mCapture Then
        Exit Sub
    End If
    
    Static p As StructMovePoint
                   
    If p.x + mLabel.Width <= mLabel.Parent.InsideWidth Then
        If p.x >= 0 Then
            If p.y >= 0 Then
                If p.y + mLabel.Height - o.y <= mLabel.Parent.InsideHeight Then
                    With mLabel
                        .Left = .Left + x - o.x
                        .Top = .Top + y - o.y
                    End With
                Else
                    mLabel.Top = mLabel.Parent.InsideHeight - mLabel.Height
                End If
            Else
                mLabel.Top = 0
            End If
        Else
            mLabel.Left = 0
        End If
    Else
        mLabel.Left = mLabel.Parent.InsideWidth - mLabel.Width
    End If
    
    p.x = mLabel.Left
    p.y = mLabel.Top
    
    mLabel.ZOrder 0
    
    mLabel.Parent.Containers.OverLapEffect OverlapContainer()
End Sub

Private Sub mLabel_MouseUp(ByVal Button As Integer, _
                               ByVal Shift As Integer, _
                               ByVal x As Single, _
                               ByVal y As Single)
    o.x = 0
    o.y = 0
    
    If mCapture Then
        PositionCheck
    End If
    
    mCapture = False
    
    With mLabel
        .SpecialEffect = fmSpecialEffectEtched
        .BackColor = cnsItemBackColor
    End With
    
    mLabel.Parent.Containers.UndoOverLapEffect
End Sub

Public Sub PositionCheck()
    Dim Containers As clsContainers
    Dim Container  As clsContainer
    Dim ret        As MoveItemAddResultEnum
    Dim tContainer As clsContainer
    Dim Area As Long, MaxArea As Long
    Dim ConItems As Collection
    
    Set Containers = mLabel.Parent.Containers
    
    Set tContainer = OverlapContainer()
    
    Set ConItems = New Collection
    If Not tContainer Is Nothing Then
        ConItems.Add tContainer
    End If
    
    For Each Container In Containers.Items
        If Not Container Is tContainer Then
            ConItems.Add Container
        End If
    Next
           
    For Each Container In ConItems
        If OverLapArea(Container.ContainerRect) > 0 Then
            ret = Container.MoveItems.AddItem(Me)
            Select Case ret
                Case MoveItemMaxCountOver
                    ItemRect = OldPositionRect()
                Case Else
            End Select
        Else
            Container.MoveItems.RemoveItem Me
        End If
    Next
    
    Set ConItems = Nothing
    OldPositionSet
End Sub

Private Function OverlapContainer() As clsContainer
    Dim Containers As clsContainers
    Dim Container  As clsContainer
    Dim Area As Long, MaxArea As Long
    
    Set Containers = mLabel.Parent.Containers
    
    ''重なっている領域が最大のコンテナを取得
    For Each Container In Containers.Items
        Area = OverLapArea(Container.ContainerRect)
        If Area > MaxArea Then
            Set OverlapContainer = Container
            MaxArea = Area
        End If
    Next
End Function

Private Function OverLapArea(ContainerRect As Rect) As Long
    Dim lngMoveItem  As Long
    Dim MoveItemRect As Rect
    Dim ConRect As Rect
    Dim lngRet  As Long
    Dim InRect  As Rect
    Dim mRect   As Rect
    
    MoveItemRect = ItemRect()
    With MoveItemRect
        mRect.Left = .Left
        mRect.Top = .Top
        mRect.Width = .Left + .Width
        mRect.Height = .Top + .Height
    End With
    
    ConRect = ContainerRect
    With ConRect
        .Left = .Left
        .Top = .Top
        .Width = .Left + .Width
        .Height = .Top + .Height
    End With
        
    lngRet = IntersectRect(InRect, mRect, ConRect)
    With InRect
        OverLapArea = (.Width - .Left) * (.Height - .Top)
    End With
End Function

Public Property Get OldPositionRect() As Rect
    OldPositionRect = mOldPositionRect
End Property

Private Sub OldPositionSet()
    With mLabel
        mOldPositionRect.Left = .Left
        mOldPositionRect.Top = .Top
        mOldPositionRect.Width = .Width
        mOldPositionRect.Height = .Height
    End With
End Sub

Public Property Get ItemRect() As Rect
    With mLabel
        ItemRect.Left = .Left
        ItemRect.Top = .Top
        ItemRect.Width = .Width
        ItemRect.Height = .Height
    End With
End Property

Public Property Let ItemRect(NewRect As Rect)
    With mLabel
         .Left = NewRect.Left
         .Top = NewRect.Top
         .Width = NewRect.Width
         .Height = NewRect.Height
    End With
    Call OldPositionSet
End Property

Public Property Get Name() As String
    Name = mLabel.Name
End Property

Public Property Get Value() As Variant
    Value = mLabel.Caption
End Property

clsMoveItems.cls

Option Explicit

'***************************************************
'クラス名 clsMoveItems
'***************************************************

Implements ILink

Public Event Parent(Parent As clsContainer)
Private WithEvents mParent As clsContainer
Private m_ParentAgent As CParentAgent

Private mMoveItems As Collection
Private mItemPositions As Collection

Private mMaxItemCount As Long
Public MaxCountCheck As Boolean

Private Sub Class_Initialize()
    Set mMoveItems = New Collection
    Set mItemPositions = New Collection
    MaxCountCheck = False
End Sub

Private Sub Class_Terminate()
    Debug.Print "clsMoveItems_Terminate"
    Set mMoveItems = Nothing
    Set mItemPositions = Nothing
End Sub

Public Property Get Item(ByVal Index As Variant) As clsMoveItem
    On Error GoTo Err_Trap:
         Select Case TypeName(Index)
             Case "Long", "Integer"
                  'CollectionのLBoundは1の為+1
                  Set Item = mMoveItems(CLng(Index) + 1&)
             Case "String"
                  'フィールド名でアクセス
                  Set Item = mMoveItems(Index)
         End Select
    On Error GoTo 0
Err_Trap:

End Property

Public Function Add(ByVal Caption As String) As clsMoveItem
    Dim MoveItem As clsMoveItem
    Dim Label As MSForms.Label
    
    Set MoveItem = New clsMoveItem
    Set Label = Parent.Parent.Controls.Add("Forms.Label.1", "Label" & Caption, True)
    Label.Caption = Caption
    MoveItem.Init Label
    
    ItemMove MoveItem
    With MoveItem.ItemRect
        mItemPositions.Add _
            Array(.Left, .Top, .Width, .Height, MoveItem.Name), MoveItem.Name
    End With
    
    mMoveItems.Add MoveItem, MoveItem.Name
    Set Add = MoveItem
End Function

Public Function AddItem(ByVal TargetMoveItem As clsMoveItem) As MoveItemAddResultEnum
    Dim MoveItem As clsMoveItem

    If IsInCollection(TargetMoveItem) Then
        Set mItemPositions = New Collection
        For Each MoveItem In mMoveItems
            With MoveItem.OldPositionRect
                mItemPositions.Add _
                    Array(.Left, .Top, .Width, .Height, MoveItem.Name), MoveItem.Name
            End With
        Next
        ItemMoveAnchor TargetMoveItem, mItemPositions(TargetMoveItem.Name)
        AddItem = MoveItemAlreadyAdd
    ElseIf (mMaxItemCount >= mMoveItems.Count + 1) Or (Not MaxCountCheck) Then
        ItemMove TargetMoveItem
        mMoveItems.Add TargetMoveItem, TargetMoveItem.Name
        With TargetMoveItem.ItemRect
            mItemPositions.Add _
                Array(.Left, .Top, .Width, .Height, TargetMoveItem.Name), TargetMoveItem.Name
        End With
        AddItem = MoveItemAddOk
    Else
        Set mParent = Parent
        mParent.Alert
        Set mParent = Nothing
        AddItem = MoveItemMaxCountOver
    End If

End Function

Property Get Items() As Collection
    Set Items = mMoveItems
End Property

Public Sub RemoveItem(ByVal MoveItem As clsMoveItem)
    If IsInCollection(MoveItem) Then
        mMoveItems.Remove CStr(MoveItem.Name)
        mItemPositions.Remove CStr(MoveItem.Name)
        AllItemMove
    End If
End Sub

Private Sub AllItemMove()
    Dim MoveItem As clsMoveItem
    Dim t As Single, lw As Single
    Dim Ih As Single, Iw As Single
    Dim OldRect As Rect
    Dim NewRect As Rect
    Dim MaxWidth As Single
    Dim SameFg As Boolean
    
    For Each MoveItem In mMoveItems
        OldRect = MoveItem.ItemRect
        Iw = MoveItem.ItemRect.Width
        
        If MaxWidth < Iw Then
            MaxWidth = Iw
        End If
        
        If t + OldRect.Height > Parent.Label.Height Then
            t = 0
            lw = lw + MaxWidth
            MaxWidth = 0
        End If
        
        With NewRect
            .Left = Parent.Label.Left + lw
            .Top = Parent.Label.Top + t
            .Width = OldRect.Width
            .Height = OldRect.Height
        End With
        
        MoveItem.ItemRect = NewRect
        t = t + OldRect.Height
    Next
End Sub

Private Sub ItemMove(ByVal TargetMoveItem As clsMoveItem)
    Dim MoveItem As clsMoveItem
    Dim t As Single, lw As Single
    Dim Ih As Single, Iw As Single
    Dim OldRect As Rect
    Dim NewRect As Rect
    Dim MaxWidth As Single

    OldRect = TargetMoveItem.ItemRect
    
    For Each MoveItem In mMoveItems
        Ih = MoveItem.ItemRect.Height
        Iw = MoveItem.ItemRect.Width
        t = t + Ih
        If MaxWidth < Iw Then
            MaxWidth = Iw
        End If
        
        If t + Ih > Parent.Label.Height Then
            t = 0
            lw = lw + MaxWidth
            MaxWidth = 0
        End If
    Next
    
    With NewRect
        .Left = Parent.Label.Left + lw
        .Top = Parent.Label.Top + t
        .Width = OldRect.Width
        .Height = OldRect.Height
    End With
    
    TargetMoveItem.ItemRect = NewRect
End Sub

Private Function IsInCollection(ByVal TargetMoveItem As clsMoveItem) As Boolean
    Dim MoveItem As clsMoveItem
    
    IsInCollection = False
    
    For Each MoveItem In mMoveItems
        If MoveItem Is TargetMoveItem Then
            IsInCollection = True
            Exit For
        End If
    Next
End Function

Private Sub ItemMoveAnchor(ByVal MoveItem As clsMoveItem, RectArray As Variant)
    Dim DefaultRect As Rect
    
    With DefaultRect
        .Left = RectArray(0)
        .Top = RectArray(1)
        .Width = RectArray(2)
        .Height = RectArray(3)
    End With

    MoveItem.ItemRect = DefaultRect
End Sub

Property Get MaxItemCount() As Long
    MaxItemCount = mMaxItemCount
End Property

Property Let MaxItemCount(ByVal MaxCount As Long)
    If MaxCount < 0 Then
        MsgBox "MaxItemCountniに設定できるのは0以上です。", vbCritical
    Else
        mMaxItemCount = MaxCount
        MaxCountCheck = True
    End If
End Property

Private Sub mParent_MaxItemCountOver()
    MsgBox mParent.Title & "の最大定員は、" & mMaxItemCount & "名です。", vbExclamation
End Sub

Private Property Get Parent() As clsContainer
    ' 親が指定した代理人を通して親と連絡を取る
    m_ParentAgent.Connect Parent
End Property

' 親が指定した代理人の連絡先を取得する
Private Sub ILink_Link(ParentAgent As CParentAgent)
    Set m_ParentAgent = ParentAgent
End Sub

CParentAgent.cls

Option Explicit

' クラスモジュール: CParentAgent

Public Event OnConnect(Parent As Object)

Private Sub Class_Terminate()
    Debug.Print TypeName(Me) & ": Class_Terminate."
End Sub

' 親と連絡を取る
Public Sub Connect(Parent As Object)
    RaiseEvent OnConnect(Parent)
End Sub

ILink.cls

Option Explicit

' クラスモジュール: ILink

' メンバを隠すためのインターフェイスクラス

Public Sub Link(ParentAgent As CParentAgent)

End Sub

Module1.bas

Option Explicit

Public Type StructMovePoint
    x As Single
    y As Single
End Type

Public Type Rect
    Left As Long
    Top  As Long
    Width As Long
    Height As Long
End Type

Public Declare Function CreateRectRgn Lib "gdi32.dll" _
                                (ByVal nLeft As Long, _
                                 ByVal nTop As Long, _
                                 ByVal nRight As Long, _
                                 ByVal nBotomm As Long) As Long

Public Declare Function RectInRegion Lib "gdi32.dll" _
                                (ByVal hrgn As Long, _
                                 lprc As Rect) As Long

Public Declare Function IntersectRect Lib "user32" _
                                (lpDestRc As Rect, _
                                 lprc1 As Rect, _
                                 lprc2 As Rect) As Long
    
Public Enum MoveItemAddResultEnum
    MoveItemNotAdd = 0
    MoveItemAddOk = 1
    MoveItemAlreadyAdd = 2
    MoveItemMaxCountOver = 3
End Enum

UserForm1.frm

Option Explicit

Private WithEvents mContainers    As clsContainers
Private WithEvents mCommandButton As MSForms.CommandButton
Private mTextBox                  As MSForms.TextBox
Private Const cnsTop              As Single = 30

Private Sub UserForm_Initialize()
    Dim MougContainer As clsContainer
    Dim Member
    Dim Members
        
    With Me
        .Width = 640
        .Height = 320
    End With

    Set mContainers = New clsContainers
    Set mContainers.Parent = Me

    ''コンテナの作成
    Set MougContainer = mContainers.Add("Moug", 20, cnsTop, 100, 140)
    With MougContainer
        .Value = "モーグ"
        .CreateTitle "Moug"
    End With
    
    With mContainers.Add("Excel", 170, cnsTop, 100, 140)
        .Value = "Excel"
        .CreateTitle "ExcelVBA講座"
        .MoveItems.MaxItemCount = 3
    End With
    
    With mContainers.Add("Access", 320, cnsTop, 100, 140)
        .Value = "Access"
        .CreateTitle "AccessVBA講座"
        .MoveItems.MaxItemCount = 6
    End With
    
    With mContainers.Add("Word", 470, cnsTop, 100, 140)
        .Value = "Word"
        .CreateTitle "WordVBA講座"
        .MoveItems.MaxItemCount = 3
    End With
    
    ''アイテムの作成
    Members = Array("yayadonさん", "ろひさん", "simpleさん", _
              "月さん", "ゴマさん", "kumattiさん", "YU-TANGさん", _
              "Kanabunさん", "Abyssさん", "みそじのおじさん")
    For Each Member In Members
        MougContainer.MoveItems.Add Member
    Next
    
    ''コマンドボタンの作成
    Set mCommandButton = Me.Controls.Add _
        ("Forms.CommandButton.1", "myCommandButton", True)
    With mCommandButton
        .Left = 20
        .Top = 140
        .Height = 20
        .Width = 50
        .Caption = "決定"
    End With
    
    ''グループ分け結果の表示用テキストボックス作成
    Set mTextBox = Me.Controls.Add _
        ("Forms.TextBox.1", "myTextBox", True)
    With mTextBox
        .Left = 80
        .Top = 160
        .Height = 120
        .SpecialEffect = fmSpecialEffectEtched
        .Width = 140
        .MultiLine = True
    End With
    
    ''見出しのラベル作成
    With Me.Controls.Add("Forms.Label.1", "lbl1", True)
        .Left = 80
        .Top = 140
        .Height = 20
        .SpecialEffect = fmSpecialEffectEtched
        .Width = 140
        .Caption = "グループ分け結果"
        .TextAlign = fmTextAlignCenter
    End With
End Sub

Private Sub UserForm_Terminate()
    Debug.Print "UserForm_Terminate"
    Set mContainers = Nothing
    Set mCommandButton = Nothing
    Set mTextBox = Nothing
End Sub

Private Sub mCommandButton_Click()
    Dim Container   As clsContainer
    Dim MoveItem        As clsMoveItem
    Dim v()             As String
    Dim i               As Long
    
    For Each Container In mContainers.Items
        For Each MoveItem In Container.MoveItems.Items
            ReDim Preserve v(i)
            v(i) = Container.Value & vbTab & MoveItem.Value
            i = i + 1
        Next
    Next
    
    mTextBox.Text = Join(v, vbCrLf)
End Sub

Private Sub mContainers_MaxItemCountOver _
    (ByVal AlertContainer As clsContainer, ByVal MaxItemCount As Long)
    MsgBox AlertContainer.Title & "の最大定員は、" & MaxItemCount & "名です。", vbExclamation
End Sub

Public Property Get Containers() As clsContainers
    Set Containers = mContainers
End Property

Is that a VB program

Is that a VB program

Yes, it is.