こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

【Excel】リストボックスにデータを重複せず昇順に表示する方法

教えてください。
ユーザーフォームにリストボックス(Listbox1)があり、日付が昇順で入力されるようになっています。
ただし、この日付データは重複が多いため重複されないよう表示しようと下記のコードを記述しましたが「実行時エラー1004 アプリケーション定義またはオブジェクト定義のエラーです」と表示されてしまいます。
これを回避し、実行させるためにはどういう風に記述を修正したらよいでしょうか?
================================================================
Private Sub UserForm_Initialize()

Dim i As Long
For i = 2 To 2000
ListBox1.AddItem Worksheets("データ").Cells(i, 1)

Dim myValue As Variant
Dim myRng As Range, myCell As Range

Set myRng = Worksheets("データ").Cells(i, 1).End(xlUp)
myValue = myRng.Value

Application.ScreenUpdating = False

myRng.Sort Worksheets("データ").Cells(i, 1), xlAscending, Header:=xlYes


With ListBox1
.Clear
For Each myCell In myRng.Resize(myRng.Rows.Count - 1).Offset(1) _
.SpecialCells(xlCellTypeVisible)
.AddItem myCell.Value
Next
.ListIndex = 0
End With
Next i
ListBox1.ListIndex = 0
End Sub
================================================================

投稿日時 - 2006-08-09 15:54:21

QNo.2329488

すぐに回答ほしいです

質問者が選んだベストアンサー

> 抽出されたデータが重複しているものが3件あるはずなのに2件しか抽出
> されません。

すみません。寝ぼけてたみたいです。#3 もおかしなコードですね...
AddItem ではなく、 List の方が楽なので変更しましたが、これで大丈夫な
はずです。きっと(´・ω・`)

Private Sub UserForm_Initialize()

  Dim i      As Long
  Dim lngR    As Long
  Dim myRng    As Range
  Dim Buffer   As Variant
  
  With Worksheets("データ")
    lngR = .Cells(65536, "A").End(xlUp).Row
    Set myRng = Range(.Cells(1, "A"), .Cells(lngR, "A"))
    myRng.Sort Key1:=myRng(1, 1), Order1:=xlAscending, Header:=xlYes
    .Range("B:B").ClearContents
    myRng.AdvancedFilter Action:=xlFilterCopy, _
               CopyToRange:=.Range("B1"), _
               Unique:=True
    lngR = .Cells(65536, "B").End(xlUp).Row
    Buffer = Range(.Cells(2, "B"), .Cells(lngR, "B")).Value
  End With
  With ListBox1
    .Clear
    .List = Buffer
    .ListIndex = 0
  End With

End Sub

投稿日時 - 2006-08-10 10:51:59

お礼

出来ました!!
どうもありがとうございました◎

投稿日時 - 2006-08-10 12:38:08

このQ&Aは役に立ちましたか?

1人が「このQ&Aが役に立った」と投票しています

回答(4)

ANo.3

すみません。#1 のコードはところどころで必要なピリオド抜けが多いので、
バグフィックスしたものを再掲しておきます。スペース節約のため、コメント
はカットしてます。

 # No.2 のコメントにも一部誤記があります。
 # ×降順ソート --> ○昇順ソート

Private Sub UserForm_Initialize()

  Dim i      As Long
  Dim lngR    As Long
  Dim myRng    As Range

  With Worksheets("データ")
    lngR = .Cells(65536, "A").End(xlUp).Row
    Set myRng = Range(.Cells(1, "A"), .Cells(lngR, "A"))
    myRng.Sort Key1:=myRng(1, 1), Order1:=xlAscending, Header:=xlYes
    .Range("B:B").ClearContents
    myRng.AdvancedFilter Action:=xlFilterCopy, _
               CopyToRange:=.Range("B1"), _
               Unique:=True
    lngR = .Cells(65536, "B").End(xlUp).Row
    Set myRng = Range(.Cells(2, "B"), .Cells(lngR, "B"))
  End With
  With ListBox1
    .Clear
    For i = 2 To lngR - 1
      .AddItem myRng.Cells(i, 1).Value
    Next i
  End With
  ListBox1.ListIndex = 0

End Sub

投稿日時 - 2006-08-09 23:57:45

補足

解答ありがとうございます。
参考にさせていただいたのですが、抽出されたデータが重複しているものが3件あるはずなのに2件しか抽出されません。
これはどの部分を修正したらよいでしょうか?

投稿日時 - 2006-08-10 09:18:04

ANo.2

AddItem だとちょっと「もたつく」感じがします。配列にして List プロパ
ティーで一気に放り込んだ方が高速です。

Range を一次元配列にする方法、配列から重複値をドロップする方法なども
あわせて書いてみました。少々難易度はあがりますが、ご参考下さい。

Private Sub UserForm_Initialize()
  ' イベントプロシージャ内にはあまり長いコードは書かないで
  ' サブプロシージャを呼び出すようにするとコードがスッキリ
  ' します
  Call SetListbox

End Sub

' リストボックスデータセット
Private Sub SetListbox()
  
  Dim i      As Long
  Dim rngDataTbl    As Range
  Dim lngR As Long
  Dim Buffer   As Variant
  
  On Error GoTo ERROR_HANDLER
  
  With ThisWorkbook.Worksheets("データ")
    ' データの最終行を求め、データ範囲を rngDataTbl に参照
    lngR = .Cells(65536, "A").End(xlUp).Row
    Set rngDataTbl = Range(.Cells(1, "A"), .Cells(lngR, "A"))
  End With
  ' 見出し付きで降順ソート
  rngDataTbl.Sort Key1:=rngDataTbl(1, 1), Order1:=xlAscending, Header:=xlYes
  ' 見出しは不要なので、データ範囲を補正
  Set rngDataTbl = rngDataTbl.Offset(1).Resize(rngDataTbl.Rows.Count - 1)
  ' データ範囲を一次元配列に変換
  Buffer = Application.Transpose(rngDataTbl.Value)
  ' 配列から重複データをドロップする
  Call GetUniqueArray(Buffer)
  ' リストボックスにデータセット
  With ListBox1
    .List = Buffer
    .ListIndex = 0
  End With
  Set rngDataTbl = Nothing
  Exit Sub

ERROR_HANDLER:
  MsgBox "ListBox にデータを追加できません.", vbExclamation
End Sub

' 重複のない配列を生成(サブプロシージャ)
Private Sub GetUniqueArray(ByRef Source As Variant)
  
  Dim colTmp As Collection
  Dim aryTmp As Variant
  Dim vntElm As Variant
  Dim i   As Long

  On Error GoTo ERROR_HANDLER

  Set colTmp = New Collection
  ' Collection には同一値を Add できない --> On Error Resume Next
  ' にすると、結果として重複値はカットされる
  On Error Resume Next
  For Each vntElm In Source
    If vntElm <> Empty Then
      colTmp.Add CStr(vntElm), CStr(vntElm)
    End If
  Next vntElm
  On Error GoTo 0
  
  If colTmp.Count = 0 Then
    Exit Sub
  Else
    ' Collection から配列に戻す
    ReDim aryTmp(colTmp.Count - 1)
    For i = 1 To colTmp.Count
      ' 書式化しておく
      aryTmp(i - 1) = Format$(CDate(colTmp.Item(i)), "yyyy/mm/dd")
    Next i
    Source = aryTmp
  End If
  Set colTmp = Nothing
  Exit Sub

ERROR_HANDLER:
  Err.Raise 1000, , "重複のない配列の生成に失敗しました."
End Sub

投稿日時 - 2006-08-09 20:20:03

お礼

すばらしい解答をありがとうございました。
自分なりに解釈し、参考にさせて頂きます。
ありがとうございました。

投稿日時 - 2006-08-10 09:17:49

ANo.1

こんにちは。KenKen_SP です。

もとのコードを最大限に活用すればこんな感じ。AdvancedFilter で重複値を
カットするため、作業用に B列 を使いました。

Private Sub UserForm_Initialize()

  Dim i      As Long
  Dim lngR    As Long
  Dim myRng    As Range

  With Worksheets("データ")
    lngR = .Cells(65536, "A").End(xlUp).Row
    Set myRng = Range(.Cells(1, "A"), Cells(lngR, "A"))
    ' 見出し付きでソート
    myRng.Sort Key1:=myRng(1, 1), Order1:=xlAscending, Header:=xlYes
    ' 重複のない日付をB列に転記
    .Range("B:B").ClearContents
    myRng.AdvancedFilter Action:=xlFilterCopy, _
               CopyToRange:=Range("B1"), _
               Unique:=True
    ' データ範囲をB列に訂正
    lngR = .Cells(65536, "B").End(xlUp).Row
    Set myRng = Range(.Cells(2, "B"), Cells(lngR, "B"))
  End With
  With ListBox1
    .Clear
    For i = 2 To lngR - 1
      .AddItem myRng.Cells(i, 1).Text
    Next i
  End With
  ListBox1.ListIndex = 0

End Sub

投稿日時 - 2006-08-09 20:15:45

あなたにオススメの質問