Hulp nodig bij aanpassen VBA code

[joeyverveer]

Hallo,

Ik ben joey, heb een eigen winkeltje waar we mede krasloten verkopen.
Nu had ik een werkend excel bestandje waarin ik mijn administratie bijhield.
En ook mijn krasloten kon scannen, waarbij deze op juiste wijze verwerkt werden.
Nu bestonden de oude scancodes van krasloten echter uit 12 digits (cijfers) (waarvan de 1e 2digits het spelnummer aangeven)
De nieuwe krasloten echter bestaand uit meer dan 12digits (cijfers) (waarbij de 1e 3digits het spelnummer aangeven, in dit geval spelnr 100 & 101)

Doordat hij enkel de eerste 2 leest, leest die dus voor 100 & 101 allebei 10.
Kan er iemand misschien een simpel regeltje inbouwen tot als de barcode langer is als 12cijfers hij de eerste 3 moet lezen op het spelnr te bepalen.
Ik ben zelf bezig geweest maar mijn kennis is te beperkt, de oude moet hij ook blijven lezen omdat deze nog in omloop zijn

alvast mijn hartelijke dank.

VBA CODE

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim spelnr As Integer, i As Integer
    
    If Target.Count > 1 Then Exit Sub
    If Target.Row > 4 And Target.Column = 1 Then
        On Error GoTo fout:
        spelnr = Left(Target, 2)
        i = Application.WorksheetFunction.Match(spelnr, Sheets("Data").Range("A2:A" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row), 0)
        Target.Offset(0, 1).Value = spelnr
        Target.Offset(0, 2).Value = Mid(Target, 3, 6)
        Target.Offset(0, 3).Value = Sheets("Data").Cells(1 + i, 2).Value
        Target.Offset(0, 4).Value = Sheets("Data").Cells(1 + i, 3).Value
        Target.Offset(0, 5).Value = Date
        Exit Sub
fout:
        MsgBox "Er is een spelnummer gescand wat nog niet in de lijst staat"
    End If

End Sub

Voor het geheel het excel bestand bij gevoegd (tabblad krasloten)

paar barcodes mbt krasloten

01011592830349 (nieuw)

01001048590808 (nieuw)

801461160073

781611211187

 

[edmoor]

Wijzig de regel:

spelnr = Left(Target, 2)

In:

If Len(Target) > 12 Then
    spelnr = Left(Target, 3)
Else
    spelnr = Left(Target, 2)
End If

 

[Cobbe]

Dit zou voldoende moeten zijn:

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim spelnr As Integer, i As Integer

 If Target.Count > 1 Then Exit Sub
 If Target.Row > 4 And Target.Column = 1 Then
 On Error GoTo fout:

 [B][/B][COLOR="#FF0000"] If Len(Target) > 12 Then
   spelnr = Left(Target, 3)
  Else
   spelnr = Left(Target, 2)
    End If[/COLOR]

 i = Application.WorksheetFunction.Match(spelnr, Sheets("Data").Range("A2:A" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row), 0)
 Target.Offset(0, 1).Value = spelnr
 Target.Offset(0, 2).Value = Mid(Target, 3, 6)
 Target.Offset(0, 3).Value = Sheets("Data").Cells(1 + i, 2).Value
 Target.Offset(0, 4).Value = Sheets("Data").Cells(1 + i, 3).Value
 Target.Offset(0, 5).Value = Date
 Exit Sub
fout:
 MsgBox "Er is een spelnummer gescand wat nog niet in de lijst staat"
 End If
 
End Sub

 

[edmoor]

Goedenavond Cobbe

 

[Cobbe]

Ja hallo, ik was aan 't slapen, vandaar mijn ietwat late reactie!
Beste wensen nog.

 

[edmoor]

Hahaha! Kan gebeuren.
En ook de beste wensen!

 

[joeyverveer]

Hey top mannen.
Ik ga hem morgen meteen toepassen.
Super erg bedankt.

Mijn dank is groot

 

[Warme bakkertje]

@ edmoor & cobbe
Eerst en vooral beste wensen voor het nieuwe jaar.
De feestdagen ziten er nog in zeker :d

spelnr = IIf(Len(Target) > 12, Left(Target, 3), Left(Target, 2))

Extra vraagje aan TS
Als het drie begincijfers zijn, klopt onderstaande regel dan nog ?

Target.Offset(0, 2).Value = Mid(Target, 3, 6)

 

[edmoor]

De Iif had ik wel aan gedacht hoor maar ik vond mijn oplossing voor TS makkelijk te begrijpen.

 

[joeyverveer]

@ edmoor & cobbe
Eerst en vooral beste wensen voor het nieuwe jaar.
De feestdagen ziten er nog in zeker :d

spelnr = IIf(Len(Target) > 12, Left(Target, 3), Left(Target, 2))

Extra vraagje aan TS
Als het drie begincijfers zijn, klopt onderstaande regel dan nog ?

Target.Offset(0, 2).Value = Mid(Target, 3, 6)

klopt idd
maar dat kon ik dan nog net zelf....
Heel vroeger databases gehad en toen nog programmeren in oldschool turbo pascal

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim spelnr As Integer, i As Integer

 If Target.Count > 1 Then Exit Sub
 If Target.Row > 4 And Target.Column = 1 Then
 On Error GoTo fout:

  If Len(Target) > 12 Then
   spelnr = Left(Target, 3)
   i = Application.WorksheetFunction.Match(spelnr, Sheets("Data").Range("A2:A" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row), 0)
    Target.Offset(0, 1).Value = spelnr
    Target.Offset(0, 2).Value = Mid(Target, 4, 6)
    Target.Offset(0, 3).Value = Sheets("Data").Cells(1 + i, 2).Value
    Target.Offset(0, 4).Value = Sheets("Data").Cells(1 + i, 3).Value
    Target.Offset(0, 5).Value = Date
  Else
   spelnr = Left(Target, 2)
   i = Application.WorksheetFunction.Match(spelnr, Sheets("Data").Range("A2:A" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row), 0)
    Target.Offset(0, 1).Value = spelnr
    Target.Offset(0, 2).Value = Mid(Target, 3, 6)
    Target.Offset(0, 3).Value = Sheets("Data").Cells(1 + i, 2).Value
    Target.Offset(0, 4).Value = Sheets("Data").Cells(1 + i, 3).Value
    Target.Offset(0, 5).Value = Date
    End If

 Exit Sub
fout:
 MsgBox "Er is een spelnummer gescand wat nog niet in de lijst staat"
 End If
 
End Sub

nogmaals bedankt, zelf was het me niet gelukt

 

[Warme bakkertje]

Dit volstaat.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim spelnr As Integer, i As Integer
 If Target.Count > 1 Then Exit Sub
 If Target.Row > 4 And Target.Column = 1 Then
    On Error GoTo fout:
    spelnr = IIf(Len(Target) > 12, Left(Target, 3), Left(Target, 2))
    i = Application.WorksheetFunction.Match(spelnr, Sheets("Data").Range("A2:A" & Sheets("Data").Cells(Rows.Count, "A").End(xlUp).Row), 0)
    Target.Offset(0, 1).Value = spelnr
    Target.Offset(0, 2).Value = IIf(Len(Target) > 12, Mid(Target, 4, 6), Mid(Target, 3, 6))
    Target.Offset(0, 3).Value = Sheets("Data").Cells(1 + i, 2).Value
    Target.Offset(0, 4).Value = Sheets("Data").Cells(1 + i, 3).Value
    Target.Offset(0, 5).Value = Date
    Exit Sub
fout:
    MsgBox "Er is een spelnummer gescand wat nog niet in de lijst staat"
 End If
End Sub