Excel VBA bestimmter Zahl/Text Code Objekt aussetzt

[Pascala]

Guten Morgen zusammen,


Ich habe im Objekt einer Tabelle einen Code der verbietet doppelte Ziffern einzutragen.
Bis auf die Ziffer 200000 darf keine doppelt sein. Alle Ziffern werden mit einem Barcode in die Tabelle gescannt.
Nun kann es sein das ein Barcode beschädigt ist oder fehlt.
Dann wäre es gut, wenn man eine Zahl oder Text hat, der bei der Eingabe den Code pausiert, und den letzten befüllten wert nochmals kopiert und darunter einfügt und im Anschluss den Code wieder fortsetzt



Wäre dies in Excel VBA umsetzbar?  


Hier der aktuelle Code:

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("A5:A3005")
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Bereich, Target) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Bereich, Target.Value) > 1 And Target.Value <> 200000 Then 'Auswahl der Zahl die doppelt gescannt werden darf. Unbekannt Aktuell "200000"
    Beep
    UserForm1.Show
    Application.EnableEvents = False
    Target.Value = ""
    Application.EnableEvents = True
    Target.Select
End If
    Dim objRange As Range, objCell As Range
    Set objRange = Intersect(Target, Range("A5:A3005"))
    If Not objRange Is Nothing Then
        Application.EnableEvents = False202
        For Each objCell In objRange
            If Not IsEmpty(objCell.Value) Then
   objCell.Offset(0, 1).Value = Now
            Else
                objCell.Offset(0, 1).Value = Empty
            End If
        Next
        Application.EnableEvents = True
    End If
Sheets(1).Range("I3:J3").Value = Application.UserName
End Sub

Danke und viele Grüße.

[schauan]

Hallöchen,

Du hast in Deinem Code ja den Fall
If Target.Value = "" Then Exit Sub

Hier verlässt Du eben nicht das Sub sondern nimmst
... Then Target.Value = Target.Offset(-1,0).Value

Du könntest die Bedingung noch auf den beschädigten Code ausdehnen. Wie erkennt man das denn? Ist der dann zu kurz? Das könnte man so abfangen:

If Target.Value = "" Or Len(Target.Value) < 13 Then ...

[Pascala]

Hi,

Wenn der Barcode beschädigt ist dann lässt er sich nicht scannen das heißt das der Benutzer keine Eingabe machen kann.
Das wäre jedoch kein Problem wenn man den Code kurz anhält und die Nummer über sich kopiert und darunter noch einmal einfügt und den Code wieder fortsetzt.

Viele Grüße.

[Pascala]

Hallo,

so nach stunden langen Googlen kam ich zum Entschluss das es nicht geht.  :17:

Jetzt ist mir folgendes eingefallen was gehen könnte. 

Und zwar wenn z.b. die Zahl 999999 eingegeben wird dann soll die letzte Zahl die in Spalte A hinzugefügt wurde um +1 addierst werden und wieder kopiert werden an der stelle der Zahl 999999.

Hätte das nun so gelöst das wenn in Spalte A 999999 erkannt wird dann so ähnlich wie dieser code hier: (funktioniert nicht so wie ich es möchte. Hängt sich auf.)

Code:

Range("A" & Cells(Rows.Count, 1).End(xlUp).Row - 1).Copy 'bis letzte beschriebene zelle kopieren                               
         Range("K" & Cells(Rows.Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues   ' in ersten Freien zelle einfügen
         Sheets("Tabelle1").Range("K1") = Range("K1") + 1
         Range("K" & Cells(Rows.Count, 1).End(xlUp).Row - 1).Copy 'bis letzte beschriebene zelle kopieren
         Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues   ' in ersten Freien zelle einfügen
         Range("K1:K10").ClearContents
         Exit Sub

Wäre wirklich genial wenn mir jemand hier weiterhelfen könnte. :)

Viele Grüße.

[schauan]

Hallöchen,

Range("A" & Cells(Rows.Count, 1).End(xlUp).Row - 1).Copy 'bis letzte beschriebene zelle kopieren

Durch -1 bist Du auf der vorletzten ...

Range("K" & Cells(Rows.Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues ' in ersten Freien zelle einfügen

Die erste freie wäre +1

Jetzt kann es natürlich sein, in der letzten steht z.B. ein Leerzeichen. Dann würde es passen.

Wen Du nur eine Zelle kopieren bzw. an einer Zellposition einfügen willst, reicht

Cells(Rows.Count, 1).End(xlUp).Copy
Cells(Rows.Count, 1).End(xlUp).Paste

Statt der 1 musst Du die richtige Spaltenzahl nehmen, 1 wäre ja immer A

Wenn Du's davor oder danach machen willst, dann z.B. mit

Cells(Rows.Count, 1).End(xlUp).Offset(1,0)...
oder
Cells(Rows.Count, 1).End(xlUp).Offset(-1,0)...

(mal nur für die Zeile)

[Pascala]

Hallo zusammen,

habe es nun so gelöst falls jemand ein ähnliches Problem hat. :)

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Bereich As Range
Set Bereich = Range("A5:A3005")
If Target.Cells.Count > 1 Then Exit Sub
If Target.Value = "" Then Exit Sub
If Intersect(Bereich, Target) Is Nothing Then Exit Sub
If WorksheetFunction.CountIf(Bereich, Target.Value) > 1 And Target.Value <> 200000 Then 'Auswahl der Zahl die doppelt gescannt werden darf. Unbekannt Aktuell "200000"
    Beep
    UserForm1.Show
    Application.EnableEvents = False
    Target.Value = ""
    Application.EnableEvents = True
    Target.Select
End If
    Dim objRange As Range, objCell As Range
    Set objRange = Intersect(Target, Range("A5:A3005"))
    If Not objRange Is Nothing Then
        Application.EnableEvents = False
        For Each objCell In objRange
            If Not IsEmpty(objCell.Value) Then
   objCell.Offset(0, 1).Value = Now
            Else
                objCell.Offset(0, 1).Value = Empty
            End If
        Next
        Application.EnableEvents = True
    End If

Dim rngGefunden As Range
Set rngGefunden = Range(Cells(1, 1), Cells(100000, 1)).Find("999999", Cells(10000, 1), xlValues, xlWhole) 'sucht nach der Ziffer 999999 in der ersten spalte
If Not rngGefunden Is Nothing Then
    Range("A" & Cells(Rows.Count, 1).End(xlUp).Row - 1).Copy 'bis letzte beschriebene zelle kopieren
    Range("K" & Cells(Rows.Count, 11).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues   ' in ersten Freien zelle einfügen
    Range("K1").Value = Range("K1").Value + 100 'Retourennummer +100
    Range("K1").Copy ' zelle kopieren
    Range("A" & Cells(Rows.Count, 1).End(xlUp).Row + 0).PasteSpecial Paste:=xlPasteValues   ' in ersten Freien zelle einfügen
    Range("K1").ClearContents ' inhalt löschen
Else
    Exit Sub
End If

End Sub