Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


38550 / 76732 ←次へ | 前へ→

【43316】Dictionaryを使った一例です?
回答  Hirofumi  - 06/10/9(月) 10:48 -

引用なし
パスワード
   Dictionaryを使った一例です?
UserFormに以下のコントロールが配置されています
  ComboBox1〜4
  CommandButton1

以下のコードをUserFormのコードモジュールに記述して下さい

Option Explicit

'UserFormモジュール内の何処からでも参照出来る定数、変数を宣言

'Listの列数(A列〜F列)
Const clngColumns As Long = 6
'集計列の先頭位置(基準位置rngListから「数量」の列Offset)
Const clngSum As Long = 3

'Listの基準セル(「取引先名」の位置)
Private rngList As Range
'Listの行数
Private lngRows As Long
'出力先の基準セル(列見出し先頭の位置)
Private rngResult As Range
'集計項目名、位置、表示の配列(表示Table用配列)
Private vntList As Variant

Private Sub UserForm_Activate()

  If lngRows = 0 Then
    MsgBox "データが有りません", vbExclamation
    Unload Me
  End If
  
End Sub

Private Sub UserForm_Initialize()

  Dim i As Long
  Dim vntData As Variant
  Dim vntItems As Variant
  Dim vntPos As Variant
  
  'Listの基準セルを設定(「取引先名」の位置)
  Set rngList = Worksheets("Sheet1").Cells(1, "A")
  
  '出力先の基準セルを設定(列見出し先頭の位置)
  Set rngResult = Worksheets("Sheet2").Cells(1, "A")
  
  'Listの列数取得
  With rngList
    lngRows = .Offset(Rows.Count - .Row).End(xlUp).Row - .Row
    If lngRows < 1 Then
      lngRows = 0
    End If
    '列見出しを取得
    vntData = .Resize(, clngColumns).Value
  End With
  
  'ComboBox1の設定
  '表示する列の位置を設定(基準セルからの列Offset)
  vntPos = Array(0, 1, 2)
  'ItemListを作成
  ReDim vntItems(UBound(vntPos), 1)
  For i = 0 To UBound(vntPos)
    vntItems(i, 0) = vntData(1, vntPos(i) + 1)
    vntItems(i, 1) = vntPos(i)
  Next i
  With ComboBox1
    'Itemを設定
    .List = vntItems
    '表示列を1列に
    .ColumnCount = 1
  End With
  
  'ComboBox1以外の設定
  '表示する列の位置を設定(clngSumからの列Offset)
  vntPos = Array(0, 1, 2)
  '表示Table用配列を作成
  ReDim vntList(1 To UBound(vntPos) + 1, 1 To 3)
  For i = 1 To UBound(vntList, 1)
    '列見だしを代入
    vntList(i, 1) = vntData(1, vntPos(i - 1) + clngSum + 1)
    '配列の2列目に-1を代入
    vntList(i, 2) = -1
    '配列の3列目に列位置を代入
    vntList(i, 3) = vntPos(i - 1)
  Next i
  
End Sub

Private Sub UserForm_Terminate()

  Set rngList = Nothing
  Set rngResult = Nothing
  
End Sub

Private Sub CommandButton1_Click()

'  集計

  Dim i As Long
  Dim j As Long
  Dim lngIndex As Long
  Dim dicIndex As Object
  Dim vntKeys As Variant
  Dim vntData As Variant
  Dim lngPos() As Long
  Dim vntResult As Variant
  Dim vntHeader As Variant
  
  'ComboBox1の値が選択されていない場合
  ReDim lngPos(0)
  With ComboBox1
    If .ListIndex = -1 Then
      'Subを抜ける
      GoTo Wayout
    Else
      'Keyの列位置を取得
      lngPos(0) = Val(.List(.ListIndex, 1))
    End If
  End With
  
  'ComboBox1以外の値が1つも選択されていない場合
  For i = 2 To 4
    With Controls("ComboBox" & i)
      If .ListIndex > -1 Then
        '集計列位置を取得
        j = j + 1
        ReDim Preserve lngPos(j)
        lngPos(j) = Val(.Tag)
      End If
    End With
  Next i
  'ComboBox1以外の値が1つも選択されていない場合
  If UBound(lngPos) = 0 Then
    'Subを抜ける
    GoTo Wayout
  End If
  
  '結果シートをクリア
  rngResult.Parent.Cells.Clear
  
  '結果出力用配列、データ用配列を確保
  ReDim vntResult(lngRows, UBound(lngPos)), _
      vntData(1 To UBound(lngPos))
  
  'Key及び集計データを取得
  With rngList
    'Keyデータを配列に取得
    vntKeys = .Offset(1, lngPos(0)).Resize(lngRows + 1).Value
    '選択された集計列の集計値を配列に取得
    For i = 1 To UBound(lngPos)
      vntData(i) = .Offset(1, clngSum _
              + lngPos(i)).Resize(lngRows + 1).Value
    Next i
  End With
  
  '列見出しを結果出力用配列に代入
  vntResult(0, 0) = ComboBox1.Text
  j = 0
  For i = 2 To 4
    With Controls("ComboBox" & i)
      If .ListIndex > -1 Then
        j = j + 1
        vntResult(0, j) = .Text
      End If
    End With
  Next i
  
  'Dictionaryオブジェクトを取得
  Set dicIndex = CreateObject("Scripting.Dictionary")
  
  '集計
  With dicIndex
    For i = 1 To lngRows
      'DictionaryにKeyが有った場合
      If .Exists(vntKeys(i, 1)) Then
        '結果配列に集計値を加算
        For j = 1 To UBound(lngPos)
          vntResult(.Item(vntKeys(i, 1)), j) _
              = vntResult(.Item(vntKeys(i, 1)), j) _
                  + vntData(j)(i, 1)
        Next j
      Else
        'DictionaryにKeyと結果配列に列位置を登録
        lngIndex = lngIndex + 1
        .Item(vntKeys(i, 1)) = lngIndex
        '結果配列にKeyと集計値を代入
        vntResult(lngIndex, 0) = vntKeys(i, 1)
        For j = 1 To UBound(lngPos)
          vntResult(lngIndex, j) = vntData(j)(i, 1)
        Next j
      End If
    Next i
  End With
  
  '結果を出力
  rngResult.Resize(lngIndex + 1, _
      UBound(lngPos) + 1).Value = vntResult
  
Wayout:
  
  Set dicIndex = Nothing
  
End Sub

Private Sub ComboBox2_Enter()

  SetCombList ComboBox2
  
End Sub

Private Sub ComboBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)

  ItemSelecte ComboBox2
  
End Sub

Private Sub ComboBox3_Enter()

  SetCombList ComboBox3
  
End Sub

Private Sub ComboBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)

  ItemSelecte ComboBox3
  
End Sub

Private Sub ComboBox4_Enter()

  SetCombList ComboBox4
  
End Sub

Private Sub ComboBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)

  ItemSelecte ComboBox4
  
End Sub

Private Sub SetCombList(cmbControl As MSForms.ComboBox)

'  ComboBoxのListを設定

  Dim i As Long
  Dim j As Long
  Dim strItem As String
  
  'ComboBoxに就いて
  With cmbControl
    '現在のValueを保存
    strItem = .Value
    'クリア
    .Clear
    '配列の行全てを繰り返す
    For i = 1 To UBound(vntList, 1)
      'もし、配列の2列目が0若しくは、自分の番号なら
      If vntList(i, 2) = -1 _
          Or vntList(i, 2) = .TabIndex Then
        'Listに配列に1列目を設定
        .AddItem vntList(i, 1)
        'もし、配列の2列目に自分の番号が有ったら
        If vntList(i, 2) = .TabIndex Then
          'その番号を0にする
          vntList(i, 2) = -1
        End If
      End If
    Next i
    .Value = strItem
  End With
  
End Sub

Private Sub ItemSelecte(cmbControl As MSForms.ComboBox)
 
' 選択されたItmeを配列に登録

  Dim i As Long
  
  'ComboBoxに就いて
  With cmbControl
    '選択されたItemを配列に登録
    If .ListIndex > -1 Then
      '配列の行全てを繰り返す
      For i = 1 To UBound(vntList, 1)
        'もし、配列の1列目に選択された値が有ったら
        If vntList(i, 1) = .List(.ListIndex, 0) Then
          'その値の番号をTabIndexの値にする
          vntList(i, 2) = .TabIndex
          'Tagに列位置を登録
          .Tag = vntList(i, 3)
          'Forを抜ける
          Exit For
        End If
      Next i
    Else
      'Tagをクリア
      .Tag = Empty
    End If
  End With
  
End Sub

1 hits

【43298】Dictionaryについて TOSHIKI 06/10/8(日) 17:54 質問
【43304】Re:Dictionaryについて neptune 06/10/8(日) 19:57 発言
【43307】Re:Dictionaryについて TOSHIKI 06/10/8(日) 20:41 発言
【43312】Re:Dictionaryについて neptune 06/10/8(日) 21:54 回答
【43313】Re:Dictionaryについて neptune 06/10/8(日) 22:02 発言
【43316】Dictionaryを使った一例です? Hirofumi 06/10/9(月) 10:48 回答
【43321】Re:Dictionaryを使った一例です? TOSHIKI 06/10/9(月) 16:24 質問
【43323】Re:Dictionaryを使った一例です? Hirofumi 06/10/9(月) 17:18 回答
【43324】Re:Dictionaryを使った一例です? Hirofumi 06/10/9(月) 17:21 回答
【43326】Re:Dictionaryを使った一例です? Hirofumi 06/10/9(月) 17:33 回答
【43325】Re:Dictionaryを使った一例です? TOSHIKI 06/10/9(月) 17:31 お礼

38550 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free