Excel VBA質問箱 IV

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

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


47447 / 76732 ←次へ | 前へ→

【34242】Re:コンボボックスで重複読込をしないようにする
回答  Hirofumi  - 06/1/29(日) 17:42 -

引用なし
パスワード
   業種が100や200ならこんな程度でも善いかも?

Option Explicit

'ComboBoxのデータの有るシート名を設定
Private Const cstrSheet As String = "アドレス帳"
'ComboBoxのデータの始まりのセル位置を設定
Private Const cstrTop As String = "A3"

Private Sub UserForm_Initialize()

  Dim vntList As Variant
  
  '重複取り
  vntList = GetCombList(cstrSheet, cstrTop)
  '戻り値が配列なら
  If IsArray(vntList) Then
    'ComboBoxのListに登録
    ComboBox1.List = GetCombList(cstrSheet, cstrTop)
  End If
  
End Sub

Private Function GetCombList(strSheet As String, strTop As String) As Variant

  Dim i As Long
  Dim j As Long
  Dim lngPos As Long
  Dim lngRows As Long
  Dim vntData As Variant
  Dim vntResult As Variant
  
  With Worksheets(strSheet).Range(strTop)
    '行数を取得
    .Offset(65536 - .Row).End(xlUp).Select
    lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row + 1
    If lngRows <= 1 And .Value = "" Then
      Exit Function
    End If
    'データを取得
    vntData = .Resize(lngRows + 1).Value
  End With
  
  '結果配列の初期の大きさを設定
  ReDim vntResult(lngPos)
  '結果配列に1行目を代入
  vntResult(lngPos) = vntData(1, 1)
  'データの最後まで繰り返し
  For i = 2 To lngRows
    '結果配列に同じ値が有るか確認
    For j = 0 To lngPos
      '同じ値が有る場合Forを抜ける
      If vntResult(j) = vntData(i, 1) Then
        Exit For
      End If
    Next j
    '同じ値が無い場合
    If j > lngPos Then
      '結果配列の最大添え字を更新
      lngPos = j
      '結果配列を拡張
      ReDim Preserve vntResult(lngPos)
      '結果配列に登録
      vntResult(lngPos) = vntData(i, 1)
    End If
  Next i
  
  GetCombList = vntResult
  
End Function
0 hits

【34231】コンボボックスで重複読込をしないようにする かとぼん 06/1/29(日) 11:31 質問
【34232】Re:コンボボックスで重複読込をしないよう... かみちゃん 06/1/29(日) 11:39 発言
【34256】ありがとうございました。 かとぼん 06/1/29(日) 20:45 お礼
【34242】Re:コンボボックスで重複読込をしないよう... Hirofumi 06/1/29(日) 17:42 回答
【34254】ありがとうございました。 かとぼん 06/1/29(日) 20:44 お礼

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