スポンサーサイト 


上記の広告は1ヶ月以上更新のないブログに表示されています。
新しい記事を書く事で広告が消せます。

--/--/--

Category: スポンサー広告

TB: --  /  CM: --

top △

プニュンで割付け 


以下の様なフォームがあったとして、
kEnt106

「XXさん」部分をドラッグして、右側の枠で離す。
グループ分けのような感じですね。

フォームは「F1」「F2」「F3」「F42」「F52」の5つを用意しました。
画面上の見え方等、一緒です。
中の記述をいろいろと・・・・

Type を使ってみたり、Collection を使ってみたり、Dictionary を使ってみたり・・・・


※ 再認識しましたが、Collection は 1 スタートなんですね。

※ やってみて Collection と Dictionary の使い勝手は、
私にとっては Collection < Dictionary ですかね。
かといって Collection は使わないという事ではないけど・・・・・
Dictionary は CreateObject しないと・・・・チョッと手間がかかりますけどね。
 
テーブル「T1」を以下のような感じで用意しておきます。
an氏名グループ更新日時
1Aさん1 
2Bさん2 
3Cさん0 
4Dさん2 
5Eさん0 
6Fさん0 
7Gさん1 
8Hさん1 
9Iさん1 
10Jさん2 

ここで言う「グループ」の値は、
0: 未割付け
1: 右上の枠に割付け
2: 右下の枠に割付け

フォームの構成は、ほとんど一緒です。
・ラベル「labs1」~「labs10」の10個
・右上枠用の四角形「bx1」
・右下枠用の四角形「bx2」
・元に戻す用コマンドボタン「btn1」
・保存用コマンドボタン「btn2」
四角形「bx1」「bx2」は、最背面にしておきます。
※ このフォームは非連結になってます。

Type を使ったフォーム「F1」「F2」「F3」

以下のような感じで宣言しておきます。
Const LABEL_MAX As Long = 10

Private Type LabArray
  ctl As Label 関連付けたラベルコントロール
  an As Long  レコードを特定するもの(テーブルの「an」)
  nGrp As Long 操作している時のグループ値
  iGrp As Long テーブル内のグループ値
End Type

Dim LabAry(1 To LABEL_MAX) As LabArray
で、フォーム読み込み時に、この配列にテーブルから得たもので作っておきます。
Private Sub RecRead()
  Dim rs As New ADODB.Recordset
  Dim i As Long

  rs.Source = "SELECT * FROM T1 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (rs.EOF) Then
        Set .ctl = Nothing
        Me("labs" & i).Visible = False
      Else
        Set .ctl = Me("labs" & i)
        .ctl.caption = rs(1)
        .iGrp = rs(2)
        .nGrp = .iGrp
        .an = rs(0)
        rs.MoveNext
      End If
    End With
  Next
  rs.Close
End Sub
ここでは、フィールドの名前を用いずに rs(0) rs(1) rs(2) のように順で扱ってみました。
rs(0): an (オートナンバ)
rs(1): 氏名
rs(2): グループ
※ テーブルのフィールド順等を変更した後では、動作が保証できない書き方だと思います。

ラベルを動かす際に「MouseDown」「MouseMove」「MouseUp」イベントを使います。
ラベルが10個あって、それぞれのラベルのイベントとして記述したら・・・・・
結構長くなるので、変数1つ作っておいて、その変数でのイベントとして処理するようにします。
記述も短くなるし、処理も一ヶ所に書くだけで済むようになります。
Dim WithEvents nCtl As Label

Private Function LabMouseDown(iNum As Long)
  If (LabAry(iNum).nGrp > 0) Then
    LabAry(iNum).nGrp = 0
    Call ShowScreen
  Else
    Set nCtl = LabAry(iNum).ctl
    nCtl.Tag = iNum
    nCtl.OnMouseMove = "[EVENT PROCEDURE]"
    nCtl.OnMouseUp = "[EVENT PROCEDURE]"
  End If
End Function

Private Sub nCtl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  On Error Resume Next
  With nCtl
'    .Move .Left + x - .Width \ 2, .Top + y - .Height \ 2
    .Left = .Left + x - .Width \ 2
    .Top = .Top + y - .Height \ 2
  End With
  Call CheckRect(nCtl)
End Sub

Private Sub nCtl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  nCtl.OnMouseMove = ""
  nCtl.OnMouseUp = ""

  If (nCtl.BackColor <> RGB(255, 255, 255)) Then
    nCtl.BackColor = RGB(255, 255, 255)
    With LabAry(nCtl.Tag)
      If (Me.bx1.BorderColor <> BDCOL_NRL) Then
        .nGrp = 1
      Else
        .nGrp = 2
      End If
    End With
  End If
  Set nCtl = Nothing
  Call ShowScreen
End Sub


Private Sub init()
  Dim i As Long

  Set nCtl = Nothing
  BDCOL_RED = RGB(255, 0, 0)
  BDCOL_NRL = 0

  Call RecRead
  Call ShowScreen

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      .ctl.OnMouseDown = "=LabMouseDown(" & i & ")"
    End With
  Next
End Sub

各ラベルの「MouseDown」で、配列の何番目のラベルで検知したものか通知します。
通知を受けたら、変数にラベルコントロールを設定し「MouseMove」「MouseUp」イベントを有効にします。
この何番目・・・は、「MouseUp」時に必要になるので、Tag を経由して通知するようにしておきます。
(外出しの変数で通知しても良いと思います)
「MouseMove」中は、マウスカーソルがラベルの中心になるようにラベル位置を変更していきます。
※ ここでの移動について
 Move は、位置・サイズを一気に指定できて便利ですが、2000 では使えないようです。
 2000 用のサンプルも作ることから、Left, Top, Width, Height 個々に指定する記述に変更。
で、「MouseUp」時に枠内にあったかを判別して、現在のグループを更新・・・ってな具合になります。

枠内にある/ないの判別は、以下のような感じで
Private Type RectXY
  x As Long
  y As Long
End Type

Private Sub RectMake(ctl As Control, iRect() As RectXY)
  With ctl
    iRect(0).x = .Left
    iRect(0).y = .Top
    iRect(1).x = .Left + .Width
    iRect(1).y = .Top
    iRect(2).x = .Left
    iRect(2).y = .Top + .Height
    iRect(3).x = .Left + .Width
    iRect(3).y = .Top + .Height
  End With
End Sub

Private Sub CheckRect(ctl As Label)
  Dim ctlRect(3) As RectXY
  Dim boxRect(3) As RectXY
  Dim bChk As Boolean

  Call RectMake(ctl, ctlRect)
  Call RectMake(Me.bx1, boxRect)

  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1

  bChk = False
  If ((ctlRect(0).x >= boxRect(0).x) And (ctlRect(0).x <= boxRect(1).x)) Then
    If ((ctlRect(0).y >= boxRect(0).y) And (ctlRect(0).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(1).x >= boxRect(0).x) And (ctlRect(1).x <= boxRect(1).x)) Then
    If ((ctlRect(1).y >= boxRect(0).y) And (ctlRect(1).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx1.BorderColor = BDCOL_RED
    Me.bx1.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  Call RectMake(Me.bx2, boxRect)

  If ((ctlRect(3).x >= boxRect(0).x) And (ctlRect(3).x <= boxRect(1).x)) Then
    If ((ctlRect(3).y >= boxRect(0).y) And (ctlRect(3).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(2).x >= boxRect(0).x) And (ctlRect(2).x <= boxRect(1).x)) Then
    If ((ctlRect(2).y >= boxRect(0).y) And (ctlRect(2).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx2.BorderColor = BDCOL_RED
    Me.bx2.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  ctl.BackColor = RGB(255, 255, 255)
End Sub
(0):左上 (1):右上 (2):左下 (3):右下
で、右上枠にあるかは (0),(1) の2点、右下枠にあるかは (2),(3) の2点を使用。
4点にしても良いと思いますが。
枠にかかった時には、ラベルの背景色も変更しておきました。

一通りの操作が終わった時点で、ラベル、四角形を再配置しています。
Private Sub ShowScreen()
  Dim vLeft As Variant
  Dim vRight As Variant
  Dim vLab As Variant
  Dim iTop As Long
  Dim i As Long
  Const IPX As Long = 567

  vLeft = Array(1#, 1#)     ' 左側の 左、上
  vRight = Array(8#, 1#, 0.5)   ' 右側の 左、上、枠の間
  vLab = Array(3#, 0.5, 0.1)   ' ラベルの幅、高さ、隙間

  iTop = vLeft(1) * IPX
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.nGrp = 0) Then
'        .ctl.Move vLeft(0) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
        With .ctl
          .Left = vLeft(0) * IPX
          .Top = iTop
          .Width = vLab(0) * IPX
          .Height = vLab(1) * IPX
        End With
        iTop = iTop + (vLab(1) + vLab(2)) * IPX
      End If
    End With
  Next

  iTop = vRight(1) * IPX
'  Me.bx1.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx1
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.nGrp = 1) Then
'        .ctl.Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
        With .ctl
          .Left = (vRight(0) + vLab(2)) * IPX
          .Top = iTop
          .Width = vLab(0) * IPX
          .Height = vLab(1) * IPX
        End With
        iTop = iTop + (vLab(1) + vLab(2)) * IPX
      End If
    End With
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx1.Height = iTop - Me.bx1.Top
  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1

  iTop = iTop + vRight(2) * IPX
'  Me.bx2.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx2
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.nGrp = 2) Then
'        .ctl.Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
        With .ctl
          .Left = (vRight(0) + vLab(2)) * IPX
          .Top = iTop
          .Width = vLab(0) * IPX
          .Height = vLab(1) * IPX
        End With
        iTop = iTop + (vLab(1) + vLab(2)) * IPX
      End If
    End With
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx2.Height = iTop - Me.bx2.Top
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1
End Sub
ラベルの幅、高さも毎回設定していましたが、画面の応答が悪くなるでもないのでそのままに。

クリアは配列内を操作して、再表示するだけ。
保存は、変更があったとこだけを・・・配列内も更新して・・・(レコードの再読み込みはしない)
Private Sub btn1_Click()
  Dim i As Long

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      .nGrp = .iGrp
    End With
  Next
  Call ShowScreen
End Sub

Private Sub btn2_Click()
  Dim sSql As String
  Dim i As Long

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.iGrp <> .nGrp) Then
        sSql = "UPDATE T1 SET 更新日時 = Now(), グループ = " & .nGrp
        sSql = sSql & " WHERE an = " & .an & ";"
        CurrentProject.Connection.Execute sSql
        .iGrp = .nGrp
      End If
    End With
  Next
End Sub
というのが大まかな記述になってます。(全部を説明したかも)


フォーム「F1」

フォーム「F1」での操作は、
右側枠内のラベルクリック時には、強制的にグループ=0に更新して再表示。

記述した VBA は以下
Const LABEL_MAX As Long = 10

Private Type LabArray
  ctl As Label
  an As Long
  nGrp As Long
  iGrp As Long
End Type

Private Type RectXY
  x As Long
  y As Long
End Type

Dim LabAry(1 To LABEL_MAX) As LabArray
Dim WithEvents nCtl As Label

Dim BDCOL_RED As Long
Dim BDCOL_NRL As Long


Private Sub RectMake(ctl As Control, iRect() As RectXY)
  With ctl
    iRect(0).x = .Left
    iRect(0).y = .Top
    iRect(1).x = .Left + .Width
    iRect(1).y = .Top
    iRect(2).x = .Left
    iRect(2).y = .Top + .Height
    iRect(3).x = .Left + .Width
    iRect(3).y = .Top + .Height
  End With
End Sub

Private Sub CheckRect(ctl As Label)
  Dim ctlRect(3) As RectXY
  Dim boxRect(3) As RectXY
  Dim bChk As Boolean

  Call RectMake(ctl, ctlRect)
  Call RectMake(Me.bx1, boxRect)

  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1

  bChk = False
  If ((ctlRect(0).x >= boxRect(0).x) And (ctlRect(0).x <= boxRect(1).x)) Then
    If ((ctlRect(0).y >= boxRect(0).y) And (ctlRect(0).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(1).x >= boxRect(0).x) And (ctlRect(1).x <= boxRect(1).x)) Then
    If ((ctlRect(1).y >= boxRect(0).y) And (ctlRect(1).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx1.BorderColor = BDCOL_RED
    Me.bx1.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  Call RectMake(Me.bx2, boxRect)

  If ((ctlRect(3).x >= boxRect(0).x) And (ctlRect(3).x <= boxRect(1).x)) Then
    If ((ctlRect(3).y >= boxRect(0).y) And (ctlRect(3).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(2).x >= boxRect(0).x) And (ctlRect(2).x <= boxRect(1).x)) Then
    If ((ctlRect(2).y >= boxRect(0).y) And (ctlRect(2).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx2.BorderColor = BDCOL_RED
    Me.bx2.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  ctl.BackColor = RGB(255, 255, 255)
End Sub

Private Sub ShowScreen()
  Dim vLeft As Variant
  Dim vRight As Variant
  Dim vLab As Variant
  Dim iTop As Long
  Dim i As Long
  Const IPX As Long = 567

  vLeft = Array(1#, 1#)     ' 左側の 左、上
  vRight = Array(8#, 1#, 0.5)   ' 右側の 左、上、枠の間
  vLab = Array(3#, 0.5, 0.1)   ' ラベルの幅、高さ、隙間

  iTop = vLeft(1) * IPX
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.nGrp = 0) Then
'        .ctl.Move vLeft(0) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
        With .ctl
          .Left = vLeft(0) * IPX
          .Top = iTop
          .Width = vLab(0) * IPX
          .Height = vLab(1) * IPX
        End With
        iTop = iTop + (vLab(1) + vLab(2)) * IPX
      End If
    End With
  Next

  iTop = vRight(1) * IPX
'  Me.bx1.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx1
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.nGrp = 1) Then
'        .ctl.Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
        With .ctl
          .Left = (vRight(0) + vLab(2)) * IPX
          .Top = iTop
          .Width = vLab(0) * IPX
          .Height = vLab(1) * IPX
        End With
        iTop = iTop + (vLab(1) + vLab(2)) * IPX
      End If
    End With
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx1.Height = iTop - Me.bx1.Top
  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1

  iTop = iTop + vRight(2) * IPX
'  Me.bx2.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx2
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.nGrp = 2) Then
'        .ctl.Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
        With .ctl
          .Left = (vRight(0) + vLab(2)) * IPX
          .Top = iTop
          .Width = vLab(0) * IPX
          .Height = vLab(1) * IPX
        End With
        iTop = iTop + (vLab(1) + vLab(2)) * IPX
      End If
    End With
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx2.Height = iTop - Me.bx2.Top
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1
End Sub

Private Sub RecRead()
  Dim rs As New ADODB.Recordset
  Dim i As Long

  rs.Source = "SELECT * FROM T1 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (rs.EOF) Then
        Set .ctl = Nothing
        Me("labs" & i).Visible = False
      Else
        Set .ctl = Me("labs" & i)
        .ctl.caption = rs(1)
        .iGrp = rs(2)
        .nGrp = .iGrp
        .an = rs(0)
        rs.MoveNext
      End If
    End With
  Next
  rs.Close
End Sub


Private Function LabMouseDown(iNum As Long)
  If (LabAry(iNum).nGrp > 0) Then
    LabAry(iNum).nGrp = 0
    Call ShowScreen
  Else
    Set nCtl = LabAry(iNum).ctl
    nCtl.Tag = iNum
    nCtl.OnMouseMove = "[EVENT PROCEDURE]"
    nCtl.OnMouseUp = "[EVENT PROCEDURE]"
  End If
End Function

Private Sub nCtl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  On Error Resume Next
  With nCtl
'    .Move .Left + x - .Width \ 2, .Top + y - .Height \ 2
    .Left = .Left + x - .Width \ 2
    .Top = .Top + y - .Height \ 2
  End With
  Call CheckRect(nCtl)
End Sub

Private Sub nCtl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  nCtl.OnMouseMove = ""
  nCtl.OnMouseUp = ""

  If (nCtl.BackColor <> RGB(255, 255, 255)) Then
    nCtl.BackColor = RGB(255, 255, 255)
    With LabAry(nCtl.Tag)
      If (Me.bx1.BorderColor <> BDCOL_NRL) Then
        .nGrp = 1
      Else
        .nGrp = 2
      End If
    End With
  End If
  Set nCtl = Nothing
  Call ShowScreen
End Sub


Private Sub init()
  Dim i As Long

  Set nCtl = Nothing
  BDCOL_RED = RGB(255, 0, 0)
  BDCOL_NRL = 0

  Call RecRead
  Call ShowScreen

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      .ctl.OnMouseDown = "=LabMouseDown(" & i & ")"
    End With
  Next
End Sub

Private Sub Form_Load()
  Call init
End Sub

Private Sub btn1_Click()
  Dim i As Long

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      .nGrp = .iGrp
    End With
  Next
  Call ShowScreen
End Sub

Private Sub btn2_Click()
  Dim sSql As String
  Dim i As Long

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      If (.iGrp <> .nGrp) Then
        sSql = "UPDATE T1 SET 更新日時 = Now(), グループ = " & .nGrp
        sSql = sSql & " WHERE an = " & .an & ";"
        CurrentProject.Connection.Execute sSql
        .iGrp = .nGrp
      End If
    End With
  Next
End Sub

 

フォーム「F2」

このフォームでは、フォーム「F1」をベースに、
右枠内のラベル操作も同様に、移動できるようにしましょう・・・・というもの
変更した箇所は以下のところ
Private Function LabMouseDown(iNum As Long)
  Set nCtl = LabAry(iNum).ctl
  nCtl.Tag = iNum
  nCtl.OnMouseMove = "[EVENT PROCEDURE]"
  nCtl.OnMouseUp = "[EVENT PROCEDURE]"
End Function

 

フォーム「F3」

前のフォーム「F1」「F2」を操作してみると、
ラベルを移動して、他のラベルと重なった場合、下に潜り込む・・・これ直したいな・・・
でも、現状ではどうやっても上下関係は解消できない。
ということで、ラベル「lab00」をもう1つ追加して、これを最前面に・・・
動かすラベルは、この「lab00」を・・・

この時、操作が若干変わります。
・移動したいラベルを1度クリックします。
・マウスをそのまま移動させます(マウスボタンは離したまま)
・終わりの時にクリックします。

ただ、この方法は CPU をかなり使うようで、ゆっくり動かします。
離れた場合は、またマウスカーソルをそのラベル上を通過させれば付いてきます。

変更した箇所は以下のところ
Private Function LabMouseDown(iNum As Long)
  With LabAry(iNum).ctl
'    Me.lab00.Move .Left, .Top, .Width, .Height
    Me.lab00.Left = .Left
    Me.lab00.Top = .Top
    Me.lab00.Width = .Width
    Me.lab00.Height = .Height
    Me.lab00.caption = .caption
    .BackColor = RGB(255, 234, 234)
  End With
  Me.lab00.Tag = iNum
  Me.lab00.Visible = True
  Set nCtl = Me.lab00
  With nCtl
    .BackColor = RGB(255, 255, 255)
    .OnMouseMove = "[EVENT PROCEDURE]"
    .OnMouseUp = "[EVENT PROCEDURE]"
  End With
End Function

Private Sub nCtl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  With nCtl
    .OnMouseMove = ""
    .OnMouseUp = ""
    If (.BackColor = RGB(255, 255, 255)) Then
      LabAry(.Tag).nGrp = 0
    Else
      If (Me.bx1.BorderColor <> BDCOL_NRL) Then
        LabAry(.Tag).nGrp = 1
      Else
        LabAry(.Tag).nGrp = 2
      End If
    End If
    .Visible = False
    LabAry(.Tag).ctl.BackColor = RGB(255, 255, 255)
  End With
  Set nCtl = Nothing
  Call ShowScreen
End Sub


Private Sub init()
  Dim i As Long

  Set nCtl = Nothing
  BDCOL_RED = RGB(255, 0, 0)
  BDCOL_NRL = 0

  Me.lab00.Visible = False
  Call RecRead
  Call ShowScreen

  For i = 1 To LABEL_MAX
    With LabAry(i)
      If (.ctl Is Nothing) Then Exit For
      .ctl.OnMouseDown = "=LabMouseDown(" & i & ")"
    End With
  Next
End Sub

 

フォーム「F42」

このフォームでは、Collection を使って、グループの管理をやってみます。
(ベースとするフォームは「F2」)

Dim LabAry(2) As New Collection
として、配列部分をグループの値として扱ってみます。

データを取り込んで設定する部分は以下のような感じです。
Private Sub RecRead()
  Dim rs As New ADODB.Recordset
  Dim ctl As Label
  Dim i As Long

  rs.Source = "SELECT * FROM T1 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  For i = 1 To LABEL_MAX
    If (rs.EOF) Then Exit For
    Set ctl = Me("labs" & i)
    With ctl
      .Visible = True
      .caption = rs(1)
      .Tag = rs(2) & "," & rs(0)
    End With
    LabAry(rs(2)).Add ctl, ctl.Name
    rs.MoveNext
  Next
  rs.Close
End Sub
一応キーとしては、ラベルの名前を使ってみました。
グループの配列として管理するだけでは、情報が足りません。
元々のグループ、レコードを一意に決定する an
この情報は、割付けたラベルの Tag 部分に ","(カンマ)区切りで格納しておくことに。
この Collection の配列は、操作中のグループを示すものになります。

操作中のグループを変更する際、
例えば、グループ(0) から グループ(2) に変更する時には
    LabAry(2).Add ctl, ctl.Name
    LabAry(0).Remove ctl.Name
のような感じで(事前に ctl を求めておいたとして)

今回、レコードを取得した順について管理していないので、チョコチョコ操作して
「クリア」した時の表示順はバラバラになりますが、グループについては元のままになります。

なお、ラベルの表示に関して初期状態は非表示としておきます。(デザインにて)

記述した VBA は以下
Const LABEL_MAX As Long = 10

Private Type RectXY
  x As Long
  y As Long
End Type

Dim LabAry(2) As New Collection
Dim WithEvents nCtl As Label

Dim BDCOL_RED As Long
Dim BDCOL_NRL As Long


Private Sub RectMake(ctl As Control, iRect() As RectXY)
  With ctl
    iRect(0).x = .Left
    iRect(0).y = .Top
    iRect(1).x = .Left + .Width
    iRect(1).y = .Top
    iRect(2).x = .Left
    iRect(2).y = .Top + .Height
    iRect(3).x = .Left + .Width
    iRect(3).y = .Top + .Height
  End With
End Sub

Private Sub CheckRect(ctl As Label)
  Dim ctlRect(3) As RectXY
  Dim boxRect(3) As RectXY
  Dim bChk As Boolean

  Call RectMake(ctl, ctlRect)
  Call RectMake(Me.bx1, boxRect)

  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1

  bChk = False
  If ((ctlRect(0).x >= boxRect(0).x) And (ctlRect(0).x <= boxRect(1).x)) Then
    If ((ctlRect(0).y >= boxRect(0).y) And (ctlRect(0).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(1).x >= boxRect(0).x) And (ctlRect(1).x <= boxRect(1).x)) Then
    If ((ctlRect(1).y >= boxRect(0).y) And (ctlRect(1).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx1.BorderColor = BDCOL_RED
    Me.bx1.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  Call RectMake(Me.bx2, boxRect)

  If ((ctlRect(3).x >= boxRect(0).x) And (ctlRect(3).x <= boxRect(1).x)) Then
    If ((ctlRect(3).y >= boxRect(0).y) And (ctlRect(3).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(2).x >= boxRect(0).x) And (ctlRect(2).x <= boxRect(1).x)) Then
    If ((ctlRect(2).y >= boxRect(0).y) And (ctlRect(2).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx2.BorderColor = BDCOL_RED
    Me.bx2.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  ctl.BackColor = RGB(255, 255, 255)
End Sub

Private Sub ShowScreen()
  Dim vLeft As Variant
  Dim vRight As Variant
  Dim vLab As Variant
  Dim iTop As Long
  Dim ctl As Label
  Dim i As Long
  Const IPX As Long = 567

  vLeft = Array(1#, 1#)     ' 左側の 左、上
  vRight = Array(8#, 1#, 0.5)   ' 右側の 左、上、枠の間
  vLab = Array(3#, 0.5, 0.1)   ' ラベルの幅、高さ、隙間

  iTop = vLeft(1) * IPX
  For Each ctl In LabAry(0)
'    ctl.Move vLeft(0) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
    With ctl
      .Left = vLeft(0) * IPX
      .Top = iTop
      .Width = vLab(0) * IPX
      .Height = vLab(1) * IPX
    End With
    iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Next

  iTop = vRight(1) * IPX
'  Me.bx1.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx1
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For Each ctl In LabAry(1)
'    ctl.Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
    With ctl
      .Left = (vRight(0) + vLab(2)) * IPX
      .Top = iTop
      .Width = vLab(0) * IPX
      .Height = vLab(1) * IPX
    End With
    iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx1.Height = iTop - Me.bx1.Top
  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1

  iTop = iTop + vRight(2) * IPX
'  Me.bx2.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx2
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For Each ctl In LabAry(2)
'    ctl.Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
    With ctl
      .Left = (vRight(0) + vLab(2)) * IPX
      .Top = iTop
      .Width = vLab(0) * IPX
      .Height = vLab(1) * IPX
    End With
    iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx2.Height = iTop - Me.bx2.Top
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1
End Sub

Private Sub RecRead()
  Dim rs As New ADODB.Recordset
  Dim ctl As Label
  Dim i As Long

  rs.Source = "SELECT * FROM T1 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  For i = 1 To LABEL_MAX
    If (rs.EOF) Then Exit For
    Set ctl = Me("labs" & i)
    With ctl
      .Visible = True
      .caption = rs(1)
      .Tag = rs(2) & "," & rs(0)
    End With
    LabAry(rs(2)).Add ctl, ctl.Name
    rs.MoveNext
  Next
  rs.Close
End Sub


Private Function LabMouseDown(sName As String)
  Set nCtl = Me(sName)
  nCtl.OnMouseMove = "[EVENT PROCEDURE]"
  nCtl.OnMouseUp = "[EVENT PROCEDURE]"
End Function

Private Sub nCtl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  On Error Resume Next
  With nCtl
'    .Move .Left + x - .Width \ 2, .Top + y - .Height \ 2
    .Left = .Left + x - .Width \ 2
    .Top = .Top + y - .Height \ 2
  End With
  Call CheckRect(nCtl)
End Sub

Private Sub nCtl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim i As Long, j As Long
  Dim ctl As Label

  nCtl.OnMouseMove = ""
  nCtl.OnMouseUp = ""

  For i = 0 To 2
    For Each ctl In LabAry(i)
      If (nCtl Is ctl) Then
        If (nCtl.BackColor = RGB(255, 255, 255)) Then
          If (i <> 0) Then
            LabAry(0).Add ctl, ctl.Name
            LabAry(i).Remove ctl.Name
          End If
        Else
          nCtl.BackColor = RGB(255, 255, 255)
          j = 0
          If (Me.bx1.BorderColor <> BDCOL_NRL) Then
            j = 1
          ElseIf (Me.bx2.BorderColor <> BDCOL_NRL) Then
            j = 2
          End If
          If (i <> j) Then
            LabAry(j).Add ctl, ctl.Name
            LabAry(i).Remove ctl.Name
          End If
        End If
        Set nCtl = Nothing
        Call ShowScreen
        Exit Sub
      End If
    Next
  Next
End Sub


Private Sub init()
  Dim ctl As Label
  Dim i As Long

  Set nCtl = Nothing
  BDCOL_RED = RGB(255, 0, 0)
  BDCOL_NRL = 0

  Call RecRead
  Call ShowScreen

  For i = 0 To 2
    For Each ctl In LabAry(i)
      ctl.OnMouseDown = "=LabMouseDown(""" & ctl.Name & """)"
    Next
  Next
End Sub

Private Sub Form_Load()
  Call init
End Sub

Private Sub btn1_Click()
  Dim i As Long, j As Long, k As Long
  Dim ctl As Label

  For i = 0 To 2
    For j = LabAry(i).Count To 1 Step -1
      Set ctl = LabAry(i)(j)
      k = Split(ctl.Tag, ",")(0)
      If (i <> k) Then
        LabAry(k).Add ctl, ctl.Name
        LabAry(i).Remove ctl.Name
      End If
      Set ctl = Nothing
    Next
  Next
  Call ShowScreen
End Sub

Private Sub btn2_Click()
  Dim sSql As String
  Dim i As Long, j As Long
  Dim ctl As Label

  For i = 0 To 2
    For Each ctl In LabAry(i)
      j = Split(ctl.Tag, ",")(0)
      If (i <> j) Then
        sSql = "UPDATE T1 SET 更新日時 = Now(), グループ = " & i
        sSql = sSql & " WHERE an = " & Split(ctl.Tag, ",")(1) & ";"
        CurrentProject.Connection.Execute sSql
        ctl.Tag = i & "," & Split(ctl.Tag, ",")(1)
      End If
    Next
  Next
End Sub

 

フォーム「F52」

このフォームでは、Dictionary を使って、グループの管理をやってみます。
(ベースとするフォームは「F2」)

Dim LabAry As Object
としておきます。

Dictionary で使用するキーは、1 ~ の数字で取得したレコード順
(割付けたラベルの順と解釈しても良いです)

そのキーに対して持つ値は、Type の時に持っていた情報を配列にして・・・
例えば、レコード読み込み時に登録しておくものは
Private Sub RecRead()
  Dim rs As New ADODB.Recordset
  Dim ctl As Label
  Dim i As Long

  rs.Source = "SELECT * FROM T1 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  For i = 1 To LABEL_MAX
    If (rs.EOF) Then Exit For
    Set ctl = Me("labs" & i)
    With ctl
      .Visible = True
      .caption = rs(1)
    End With
    LabAry.Add i, Array(ctl, rs(2).Value, rs(2).Value, rs(0).Value)
    rs.MoveNext
  Next
  rs.Close
End Sub
Array の中身は・・・・というと
割付けたラベルコントロール, 今のグループ, 元のグループ, レコード特定(an)
で、操作している時には、今のグループを変更していきます。

このフォームも、ラベルの初期表示は不可視としておきます。

記述した VBA は以下
Const LABEL_MAX As Long = 10

Private Type RectXY
  x As Long
  y As Long
End Type

Dim LabAry As Object
Dim WithEvents nCtl As Label

Dim BDCOL_RED As Long
Dim BDCOL_NRL As Long


Private Sub RectMake(ctl As Control, iRect() As RectXY)
  With ctl
    iRect(0).x = .Left
    iRect(0).y = .Top
    iRect(1).x = .Left + .Width
    iRect(1).y = .Top
    iRect(2).x = .Left
    iRect(2).y = .Top + .Height
    iRect(3).x = .Left + .Width
    iRect(3).y = .Top + .Height
  End With
End Sub

Private Sub CheckRect(ctl As Label)
  Dim ctlRect(3) As RectXY
  Dim boxRect(3) As RectXY
  Dim bChk As Boolean

  Call RectMake(ctl, ctlRect)
  Call RectMake(Me.bx1, boxRect)

  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1

  bChk = False
  If ((ctlRect(0).x >= boxRect(0).x) And (ctlRect(0).x <= boxRect(1).x)) Then
    If ((ctlRect(0).y >= boxRect(0).y) And (ctlRect(0).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(1).x >= boxRect(0).x) And (ctlRect(1).x <= boxRect(1).x)) Then
    If ((ctlRect(1).y >= boxRect(0).y) And (ctlRect(1).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx1.BorderColor = BDCOL_RED
    Me.bx1.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  Call RectMake(Me.bx2, boxRect)

  If ((ctlRect(3).x >= boxRect(0).x) And (ctlRect(3).x <= boxRect(1).x)) Then
    If ((ctlRect(3).y >= boxRect(0).y) And (ctlRect(3).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If ((ctlRect(2).x >= boxRect(0).x) And (ctlRect(2).x <= boxRect(1).x)) Then
    If ((ctlRect(2).y >= boxRect(0).y) And (ctlRect(2).y <= boxRect(3).y)) Then
      bChk = True
    End If
  End If
  If (bChk) Then
    Me.bx2.BorderColor = BDCOL_RED
    Me.bx2.BorderWidth = 3
    ctl.BackColor = RGB(255, 255, 128)
    Exit Sub
  End If

  ctl.BackColor = RGB(255, 255, 255)
End Sub

Private Sub ShowScreen()
  Dim vLeft As Variant
  Dim vRight As Variant
  Dim vLab As Variant
  Dim iTop As Long
  Dim v As Variant
  Const IPX As Long = 567

  vLeft = Array(1#, 1#)     ' 左側の 左、上
  vRight = Array(8#, 1#, 0.5)   ' 右側の 左、上、枠の間
  vLab = Array(3#, 0.5, 0.1)   ' ラベルの幅、高さ、隙間

  iTop = vLeft(1) * IPX
  For Each v In LabAry.items
    If (v(1) = 0) Then
'      v(0).Move vLeft(0) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
      With v(0)
        .Left = vLeft(0) * IPX
        .Top = iTop
        .Width = vLab(0) * IPX
        .Height = vLab(1) * IPX
      End With
      iTop = iTop + (vLab(1) + vLab(2)) * IPX
    End If
  Next

  iTop = vRight(1) * IPX
'  Me.bx1.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx1
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For Each v In LabAry.items
    If (v(1) = 1) Then
'      v(0).Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
      With v(0)
        .Left = (vRight(0) + vLab(2)) * IPX
        .Top = iTop
        .Width = vLab(0) * IPX
        .Height = vLab(1) * IPX
      End With
      iTop = iTop + (vLab(1) + vLab(2)) * IPX
    End If
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx1.Height = iTop - Me.bx1.Top
  Me.bx1.BorderColor = BDCOL_NRL
  Me.bx1.BorderWidth = 1

  iTop = iTop + vRight(2) * IPX
'  Me.bx2.Move vRight(0) * IPX, iTop, (vLab(0) + vLab(2) * 2) * IPX, (vLab(1) + vLab(2) * 2) * IPX
  With Me.bx2
    .Left = vRight(0) * IPX
    .Top = iTop
    .Width = (vLab(0) + vLab(2) * 2) * IPX
    .Height = (vLab(1) + vLab(2) * 2) * IPX
  End With
  iTop = iTop + vLab(2) * IPX
  For Each v In LabAry.items
    If (v(1) = 2) Then
'      v(0).Move (vRight(0) + vLab(2)) * IPX, iTop, vLab(0) * IPX, vLab(1) * IPX
      With v(0)
        .Left = (vRight(0) + vLab(2)) * IPX
        .Top = iTop
        .Width = vLab(0) * IPX
        .Height = vLab(1) * IPX
      End With
      iTop = iTop + (vLab(1) + vLab(2)) * IPX
    End If
  Next
  iTop = iTop + (vLab(1) + vLab(2)) * IPX
  Me.bx2.Height = iTop - Me.bx2.Top
  Me.bx2.BorderColor = BDCOL_NRL
  Me.bx2.BorderWidth = 1
End Sub

Private Sub RecRead()
  Dim rs As New ADODB.Recordset
  Dim ctl As Label
  Dim i As Long

  rs.Source = "SELECT * FROM T1 ORDER BY an;"
  rs.Open , CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly
  For i = 1 To LABEL_MAX
    If (rs.EOF) Then Exit For
    Set ctl = Me("labs" & i)
    With ctl
      .Visible = True
      .caption = rs(1)
    End With
    LabAry.Add i, Array(ctl, rs(2).Value, rs(2).Value, rs(0).Value)
    rs.MoveNext
  Next
  rs.Close
End Sub


Private Function LabMouseDown(iNum As Long)
  Set nCtl = LabAry.Item(iNum)(0)
  nCtl.Tag = iNum
  nCtl.OnMouseMove = "[EVENT PROCEDURE]"
  nCtl.OnMouseUp = "[EVENT PROCEDURE]"
End Function

Private Sub nCtl_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
  On Error Resume Next
  With nCtl
'    .Move .Left + x - .Width \ 2, .Top + y - .Height \ 2
    .Left = .Left + x - .Width \ 2
    .Top = .Top + y - .Height \ 2
  End With
  Call CheckRect(nCtl)
End Sub

Private Sub nCtl_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
  Dim i As Long, j As Long

  nCtl.OnMouseMove = ""
  nCtl.OnMouseUp = ""

  i = nCtl.Tag
  If (nCtl.BackColor = RGB(255, 255, 255)) Then
    j = 0
  Else
    nCtl.BackColor = RGB(255, 255, 255)
    If (Me.bx1.BorderColor <> BDCOL_NRL) Then
      j = 1
    Else
      j = 2
    End If
  End If
  LabAry.Item(i) = Array(LabAry.Item(i)(0), j, LabAry.Item(i)(2), LabAry.Item(i)(3))
  Set nCtl = Nothing
  Call ShowScreen
End Sub


Private Sub init()
  Dim ctl As Label
  Dim i As Long

  Set nCtl = Nothing
  BDCOL_RED = RGB(255, 0, 0)
  BDCOL_NRL = 0

  Set LabAry = CreateObject("Scripting.Dictionary")
  Call RecRead
  Call ShowScreen

  For i = 1 To LabAry.Count
    LabAry.Item(i)(0).OnMouseDown = "=LabMouseDown(" & i & ")"
  Next
End Sub

Private Sub Form_Load()
  Call init
End Sub

Private Sub Form_Close()
  Set LabAry = Nothing
End Sub

Private Sub btn1_Click()
  Dim i As Long

  For i = 1 To LabAry.Count
    LabAry.Item(i) = Array(LabAry.Item(i)(0), LabAry.Item(i)(2), LabAry.Item(i)(2), LabAry.Item(i)(3))
  Next
  Call ShowScreen
End Sub

Private Sub btn2_Click()
  Dim sSql As String
  Dim i As Long, j As Long, k As Long
  Dim ctl As Label

  For i = 1 To LabAry.Count
    j = LabAry.Item(i)(1)
    k = LabAry.Item(i)(2)
    If (j <> k) Then
      sSql = "UPDATE T1 SET 更新日時 = Now(), グループ = " & j
      sSql = sSql & " WHERE an = " & LabAry.Item(i)(3) & ";"
      CurrentProject.Connection.Execute sSql
      LabAry.Item(i) = Array(LabAry.Item(i)(0), j, j, LabAry.Item(i)(3))
    End If
  Next
End Sub

 

いろいろやってきてみて、
イメージしやすい、記述しやすいのは Type を使ったものでしょうか。
Type を使わずに、同じ配列数の異なる変数を複数持つ・・・・・これもありなんでしょうけど
(Private で Type を使えるのを知るまでは、私もそうでした。また、今でも時々やります)
単にグルーピングだけであれば、Collection は便利なのかなぁ・・・・


余談)

Dictionary を使用して、キーの重複を省くことをやる場合、
  Dim dic As Object

  Set dic = CreateObject("Scripting.Dictionary")

  dic.Add "abc", Null
  If (Not dic.exists("abc")) Then
    dic.Add "abc", Null
  End If
って、あるかないかを判別して・・・・っていう書き方が多いようですが
  Dim dic As Object

  Set dic = CreateObject("Scripting.Dictionary")

  dic.Item("abc") = Null
  dic.Item("abc") = Null
とやっても結果は同じになります。
どの道 Add で重複があるかないかを内部でやっていると思われるので、
そのキーがなかったら追加して値を設定する・・・・・の方が速そうなのだけれども。
(上記では値は何でも良くて、キーの重複だけを見たいんだから)


サンプルは以下
 バージョン 20002003 (2002)2007
 ファイル kEnt106_2000.zipkEnt106_2003.zipkEnt106_2007.zip
 サイズ 64,45981,68785,615
※ ファイルは zip 形式
※ 2007 以外は、2007 保存時に変換 & 各バージョンで動作確認 & 最適化

関連記事

2011/11/26

Category: サンプルかな

TB: 0  /  CM: 0

top △

この記事に対するコメント

top △

コメントの投稿

Secret

top △

トラックバック

トラックバックURL
→http://kikutips.blog13.fc2.com/tb.php/106-5a44be6f
この記事にトラックバックする(FC2ブログユーザー)

top △


上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。