Microsoft ExcelでVBAを使用してワークシートからの固有の値でリストボックスを塗りつぶし
この記事では、ユーザーフォームにリストボックスを作成し、重複する値を削除した後、値をロードします。
リストボックスに挿入する生データは、名前で構成されています。この生データには、定義された名前の重複が含まれています。
この例では、リストボックスで構成されるユーザーフォームを作成しました。
このリストボックスには、サンプルデータからの一意の名前が表示されます。ユーザーフォームをアクティブにするには、送信ボタンをクリックします。
このユーザーフォームは、ユーザーが選択した名前をメッセージボックスの出力として返します。
ロジックの説明
リストボックスに名前を追加する前に、コレクションオブジェクトを使用して重複する名前を削除しました。
重複するエントリを削除するために、次の手順を実行しました。 Excelシートで定義された範囲の名前をコレクションオブジェクトに追加しました。コレクションオブジェクトに、重複する値を挿入することはできません。そのため、Collectionオブジェクトは、重複する値を検出するとエラーをスローします。エラーを処理するために、「On ErrorResumeNext」というエラーステートメントを使用しました。
。コレクションを準備したら、コレクションのすべてのアイテムを配列に追加します。
。次に、すべての配列要素をリストボックスに挿入します。
コードについては以下に従ってください
Option Explicit
Sub running()
UserForm1.Show
End Sub
'Add below code in userform
Option Explicit
Private Sub CommandButton1_Click()
Dim var1 As String
Dim i As Integer
'Looping through all the values present in the list box
'Assigning the selected value to variable var1
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) Then
var1 = ListBox1.List(i)
Exit For
End If
Next
'Unload the userform.
Unload Me
'Displaying the selected value
MsgBox "You have selected following name in the List Box : " & var1
End Sub
Private Sub UserForm_Initialize()
Dim MyUniqueList As Variant, i As Long
'Calling UniqueItemList function
'Assigning the range as input parameter
MyUniqueList = UniqueItemList(Range("A12:A100"), True)
With Me.ListBox1
'Clearing the List Box content
.Clear
'Adding values in the List Box
For i = 1 To UBound(MyUniqueList)
.AddItem MyUniqueList(i)
Next i
'Selecting the first item
.ListIndex = 0
End With
End Sub
Private Function UniqueItemList(InputRange As Range, _
HorizontalList As Boolean) As Variant
Dim cl As Range, cUnique As New Collection, i As Long
'Declaring a dynamic array
Dim uList() As Variant
'Declaring this function as volatile
'Means function will be recalculated whenever calculation occurs in any cell
Application.Volatile
On Error Resume Next
'Adding items to collection
'Only unique item will be inserted
'Inserting duplicate item will through an error
For Each cl In InputRange
If cl.Value <> "" Then
'Adding values in collection
cUnique.Add cl.Value, CStr(cl.Value)
End If
Next cl
'Initializing value return by the function
UniqueItemList = ""
If cUnique.Count > 0 Then
'Resizing the array size
ReDim uList(1 To cUnique.Count)
'Inserting values from collection to array
For i = 1 To cUnique.Count
uList(i) = cUnique(i)
Next i
UniqueItemList = uList
'Checking the value of HorizontalList
'If value is true then transposing value of UniqueItemList
If Not HorizontalList Then
UniqueItemList = _
Application.WorksheetFunction.Transpose(UniqueItemList)
End If
End If
On Error GoTo 0
End Function
このブログが気に入ったら、FacebookやFacebookで友達と共有してください。
私たちはあなたから話を聞くのが大好きです、私たちがどのように私たちの仕事を改善し、あなたのためにそれをより良くすることができるかを私たちに知らせてください。 [email protected]までご連絡ください