Prosím o upravu zápisu vyhledání

[junis]

Mám kód kdy mi vyhledá zboží (dle kódu) v sestavě (to je list1 pojmenovaný jako "Sestava"), zapíše do řádku 17 (1) jedničku
Pokud nenajde vyskočí MsgBox s hlášením..

Potřeboval bych kod upravit:
Aby při opakovaném (duplicitním) načtení stejného již načteného kódu vyskočil také MsgBox s hlášením (Kód byl již v inventuře načten)
To zmamená, pokud je již v příslušném řádku ve sloupci 17 zapsaná 1 (jenička) vyskočí upozornění




Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$I$2" Then
If Not IsEmpty(Target) Then
On Error Resume Next
With Sheets("Sestava").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("Sestava").Columns(14), 0), 17)
If Err.Number = 0 Then
.Value = 1
Target.ClearContents
Else
MsgBox "Neznámý kód! Produkt nenalezen. Opakuj načtení"
End If
End With 'Sheets("Sestava").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("Sestava").Columns(14), 0), 17)
On Error GoTo 0


End If
End If
End Sub

[Reklama]

[elninoslov]

Príklad:

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Kod As String
   
    If Not Intersect(Range("$I$2"), Target) Is Nothing Then
        Kod = Range("$I$2").Value2
       
        If Len(Kod) > 0 Then
            On Error Resume Next
            With Sheets("Sestava").Cells(WorksheetFunction.Match(Kod, Sheets("Sestava").Columns(14), 0), 17)
                If Err.Number = 0 Then
                    If .Value <> "" Then MsgBox "Kód byl již v inventuře načten", vbExclamation, "Upozornění" Else .Value = 1
                    Range("$I$2").ClearContents
                Else
                    MsgBox "Neznámý kód! Produkt nenalezen. Opakuj načtení", vbCritical, "Chyba"
                End If
            End With 'Sheets("Sestava").Cells(WorksheetFunction.Match(Kod, Sheets("Sestava").Columns(14), 0), 17)
            On Error GoTo 0
        End If
    End If
End Sub

[junis]

Díky, už se mi podařilo vyřešit. Ale je to přesně ono. Děkuju