Private Sub PopulateDescriptions(ByVal Code As String)
Dim CodeRng As Range
Dim MatchCell As Range
Dim Descriptions() As String
Dim Count As Long
Dim FirstAddress As String
Set CodeRng = ThisWorkbook.Worksheets("Data").Range("CODE")
Count = 0
With CodeRng
Set MatchCell = .Find(What:=Code, LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True, MatchByte:=False)
If Not MatchCell Is Nothing Then
FirstAddress = MatchCell.Address
Count = Count + 1
ReDim Preserve Descriptions(1 To Count)
Descriptions(Count) = MatchCell.Offset(0, 1).Text
Do
Set MatchCell = .FindNext(MatchCell)
If (Not MatchCell Is Nothing) And MatchCell.Address <> FirstAddress Then
Count = Count + 1
ReDim Preserve Descriptions(1 To Count)
Descriptions(Count) = MatchCell.Offset(0, 1).Text
End If
Loop While Not MatchCell Is Nothing And MatchCell.Address <> FirstAddress
End If
End With
With cboDescriptions
.Clear
If Count > 0 Then
.List = Descriptions
End If
End With
End Sub