Gruppe
Grafik
Problem
Bei Eingabe einer Artikel-Nummer in Zelle D2 wird ausser der Benennung in Zelle D4 auch das zugehörige Symbol aus Spalte C der Quelltabelle übernommen.
ClassModule: Tabelle3
Private Sub Worksheet_Change(ByVal Target As Range)
Dim shp As Shape
Dim sAdr As String
If Target.Address <> "$D$2" Then Exit Sub
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
For Each shp In ActiveSheet.Shapes
shp.Delete
Next shp
If IsEmpty(Target) Then
Range("D4").ClearContents
GoTo ERRORHANDLER
End If
With Worksheets("Daten")
If IsError(Application.Match(Target.Value, .Range("ArtNr"), 0)) Then
Beep
Range("D4").ClearContents
MsgBox "Artikel-Nr. " & Target.Value & " wurde nicht gefunden!"
GoTo ERRORHANDLER
End If
Range("D4").Value = WorksheetFunction.VLookup(Target.Value, .Range("Artikel"), 2, 0)
sAdr = CStr(WorksheetFunction.Match(Target.Value, .Range("ArtNr"), 0) + 1)
sAdr = Cells(CInt(sAdr), 3).Address
For Each shp In .Shapes
If shp.TopLeftCell.Address = sAdr Then
shp.Copy
Range("D6").Select
ActiveSheet.Paste
Range("D2").Select
End If
Next shp
End With
ERRORHANDLER:
Application.EnableEvents = True
End Sub