[原创] Find查询与字典的应用

Sub 生成材料名称()
On Error Resume Next
    Dim Dic1, str As String
    Set Dic1 = CreateObject("scripting.dictionary")
    For Item = 2 To Cells(Rows.Count, 3).End(xlUp).Row
        Dic1.Item(Cells(Item, 3).Value) = Cells(Item, 3).Value
    Next
    With [k3].Validation
        .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=Join(Dic1.items, ",")
    End With
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target(1).Address = "$K$3" Then
        If Len(Target(1)) > 0 Then
            Range("L3:L10000").Clear
            Dim cell As Range, firstAddress As String, arr(1 To 10000, 1 To 1), i As Integer
            With Worksheets(1).Range("C:C")
                Set cell = .Find(Target, LookAt:=xlWhole, LookIn:=xlValues)
                If Not cell Is Nothing Then
               
                    firstAddress = cell.Address
                    Do
                    i = i + 1
                       arr(i, 1) = cell.Offset(0, 1).Value
                        Set cell = .FindNext(cell)
                    Loop While cell.Address <> firstAddress
                End If
            End With
            With [l3].Resize(i, 1)
            .Value = arr
            .Borders.LineStyle = xlContinuous
            .HorizontalAlignment = xlCenter
            End With
        End If
    End If
End Sub