【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
================================================================

回答No.4

KenKen_SP · ベストアンサー

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

すみません。寝ぼけてたみたいです。#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

お礼

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

回答No.3

KenKen_SP

すみません。#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

補足

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

回答No.2

KenKen_SP

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

お礼

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

回答No.1

KenKen_SP

こんにちは。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