Einzigartige DokNr erzeugen

[grünschnabel]

Hallo,
 
ich brauche bitte eure Hilfe.
 
Ich habe eine Tabelle in der die Codes für Produkte gelistet sind. Aus diesen Codes werden Dokumentennummern kreiert, die einzigartig sein müssen.
Die Dokumentennummer ist folgendermaßen aufgebaut: DOC-Code1_Code2 (kann aus beliebig vielen Codes bestehen)
Gibt es von einem Dokument mehrere Varianten, dann wird eine Nummerierung angefügt (z.B.: DOC-Code1_Code2-01, DOC-Code1_Code2-02, etc).
 
Ich habe zum besseren Verständnis ein Beispieldokument angefügt. Im Tabellenblatt “DocNo“ sollen in Zelle B1 über ein Dropdown mit Mehrfachauswahl die Codes ausgewählt werden. Das mit der Mehrfachauswahl habe ich Dank eines Beispiels aus dem Internet noch hinbekommen. Aber weiter komme ich jetzt nicht mehr.
Die ausgewählten Codes in B1 sollen aufsteigend sortiert werden (dh. nicht 35075_16384_35209, sondern 16384_35075_35209) und die Bezeichnung “DOC-“ soll noch vor die Codes gestellt werden. Dann soll geprüft werden, ob diese Dokumentennummer bereits vergeben wurde. Wenn nein, dann soll die Dokumentennummer in die Tabelle übernommen werden (im Bsp. in Zelle A11) und die Zelle B1 soll wieder leer sein.
Wenn die Dokumentennummer bereits vorhanden ist, dann soll automatisch eine Nummerierung angefügt (-01, -02, …) werden und diese Dokumentennummer in die Tabelle übernommen werden.
 
Ist so etwas in Excel möglich? Wenn ja, wie??? Leider kenne ich mich in Excel noch nicht so gut aus …  :s 
 
Bin für jede Hilfe dankbar!
 
LG


  Einzigartige DokNr erzeugen.xlsm (Größe: 18,86 KB / Downloads: 10)

[schauan]

Hallöchen,

hier wäre mal ein erster Ansatz.

Ich nutze im Code den Bereich der Spalte D zum sortieren - wenn der belegt ist, bitte andere Spalte programmieren.

Code:

Sub sortieren()
'Variablendeklaration
'Variant
Dim arrCodes
'Aus Texteintrag in B1 array bilden
arrCodes = Split(Cells(1, 2).Value, "_")
'Array ab D1 nach unten eintragen
Range("D1").Resize(UBound(arrCodes) + 1, 1) = WorksheetFunction.Transpose(arrCodes)
'teilweise aufgezeichnet
'Sortieren zuruecksetzen
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Clear
'Im durch Array gefuellten Bereich von Spalte D sortieren
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Add Key:=Range("D1:D" & UBound(arrCodes) + 1), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
Sortierung anwenden
With ActiveWorkbook.Worksheets("DocNo").Sort
    .SetRange Range("D1:D" & UBound(arrCodes) + 1)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'String zusammensetzen
arrCodes = "DOC-" & Join(WorksheetFunction.Transpose(Range("D1:D" & UBound(arrCodes) + 1)), "_")
'eingetragene Daten in D loeschen
Range("D1:D" & UBound(arrCodes) + 1) = ""
'String als Meldung ausgeben
MsgBox arrCodes
End Sub

[grünschnabel]

Guten Abend,

vielen Dank für die rasche Antwort!!

Ich habe deinen Code genommen und reinkopiert. Den Text "Sortierung anwenden" habe ich noch auskommentiert, ansonsten habe ich nichts verändert. 
Wenn ich auf Sub/UserForm ausführen gehe, kommt die Meldung "Laufzeitfehler 13: Typen unverträglich". Die Sortierung in Spalte D wird noch durchgeführt, und dann hängt es irgendwie. Habe ich da irgendwo was falsch gemacht, oder was bedeutet das?

LG

[schauan]

Hallöchen,

Bei join oder später?

[grünschnabel]

Guten Morgen,

ja, bei join.

LG

[schauan]

Hallöchen,

da war beim join schon das ubound... nicht mehr erreichbar

Dann so:

Code:

Sub sortieren()
'Variablendeklaration
'Variant
Dim arrCodes, iCnt%
'Aus Texteintrag in B1 array bilden
arrCodes = Split(Cells(1, 2).Value, "_")
'Array ab D1 nach unten eintragen
Range("D1").Resize(UBound(arrCodes) + 1, 1) = WorksheetFunction.Transpose(arrCodes)
'teilweise aufgezeichnet
'Sortieren zuruecksetzen
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Clear
'Im durch Array gefuellten Bereich von Spalte D sortieren
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Add Key:=Range("D1:D" & UBound(arrCodes) + 1), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sortierung anwenden
With ActiveWorkbook.Worksheets("DocNo").Sort
    .SetRange Range("D1:D" & UBound(arrCodes) + 1)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'String zusammensetzen
iCnt = UBound(arrCodes) + 1
arrCodes = "DOC-" & Join(WorksheetFunction.Transpose(Range("D1:D" & iCnt)), "_")
'eingetragene Daten in D loeschen
Range("D1:D" & iCnt) = ""
'String als Meldung ausgeben
MsgBox arrCodes
End Sub

[grünschnabel]

Hi,

danke, jetzt läuft es!
Wenn ich jedoch nur einen Code auswähle, dann bleibt es wieder hängen.

LG

[schauan]

Hallöchen,

so, jetzt ist das auch berücksichtigt. Nächster Step wäre die Prüfung auf doppelte?

Code:

Sub sortieren()
'Variablendeklaration
'Variant
Dim arrCodes, iCnt%
'Aus Texteintrag in B1 array bilden
arrCodes = Split(Cells(1, 2).Value, "_")
'Array ab D1 nach unten eintragen
Range("D1").Resize(UBound(arrCodes) + 1, 1) = WorksheetFunction.Transpose(arrCodes)
'teilweise aufgezeichnet
'Sortieren zuruecksetzen
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Clear
'Im durch Array gefuellten Bereich von Spalte D sortieren
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Add Key:=Range("D1:D" & UBound(arrCodes) + 1), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sortierung anwenden
With ActiveWorkbook.Worksheets("DocNo").Sort
    .SetRange Range("D1:D" & UBound(arrCodes) + 1)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'Anzahl der Array-Elemente feststellen
iCnt = UBound(arrCodes) + 1
'wenn mehrere Daten enthalten sind, dann
If iCnt > 1 Then
  'String mit D1:Dxxx und Underline als Trennung zusammensetzen
  arrCodes = "DOC-" & Join(WorksheetFunction.Transpose(Range("D1:D" & iCnt)), "_")
Else
  'String mt D1 zusammensetzen
  arrCodes = "DOC-" & Range("D1")
'Ende wenn mehrere Daten enthalten sind, dann
End If
'eingetragene Daten in D loeschen
Range("D1:D" & iCnt) = ""
'String als Meldung ausgeben
MsgBox arrCodes
End Sub

[grünschnabel]

Perfekt - es funktioniert!
Vielen Dank!!!

Ja, jetzt sollte noch die Prüfung erfolgen, ob es so eine Nr. schon gibt.

LG

[schauan]

Hallöchen,

meinst Du so?

Code:

Sub sortieren()
'Variablendeklaration
'Variant
Dim arrCodes, iCnt%, jCnt%
'Aus Texteintrag in B1 array bilden
arrCodes = Split(Cells(1, 2).Value, "_")
'Array ab D1 nach unten eintragen
Range("D1").Resize(UBound(arrCodes) + 1, 1) = WorksheetFunction.Transpose(arrCodes)
'teilweise aufgezeichnet
'Sortieren zuruecksetzen
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Clear
'Im durch Array gefuellten Bereich von Spalte D sortieren
ActiveWorkbook.Worksheets("DocNo").Sort.SortFields.Add Key:=Range("D1:D" & UBound(arrCodes) + 1), _
    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'Sortierung anwenden
With ActiveWorkbook.Worksheets("DocNo").Sort
    .SetRange Range("D1:D" & UBound(arrCodes) + 1)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
'Anzahl der Array-Elemente feststellen
iCnt = UBound(arrCodes) + 1
arrCodes = WorksheetFunction.Transpose(Range("D1:D" & iCnt))
'wenn mehrere Daten enthalten sind, dann
If iCnt > 1 Then
  'auf Mehrfachwahl pruefen
  'Schleife ueber alle Elemente
  For jCnt = 1 To iCnt
    'Wenn Inhalt der Zelle mehr als 1x vorkommt, dann
    If WorksheetFunction.CountIf(Range("D1:D" & iCnt), Range("D" & jCnt)) > 1 Then
      'Anzahl bis Zeile jCnt hinzufuegen
      arrCodes(jCnt) = Range("D" & jCnt) & "-(" & Format(WorksheetFunction.CountIf(Range("D1:D" & jCnt), Range("D" & jCnt)), "00") & ")"
    'Ende Wenn Inhalt der Zelle mehr als 1x vorkommt, dann
    End If
  'Ende Schleife ueber alle Elemente
  Next
  'String mit D1:Dxxx und Underline als Trennung zusammensetzen
  arrCodes = "DOC-" & Join(arrCodes, "_")
'  arrCodes = "DOC-" & Join(WorksheetFunction.Transpose(Range("D1:D" & iCnt)), "_")
Else
  'String mt D1 zusammensetzen
  arrCodes = "DOC-" & Range("D1")
'Ende wenn mehrere Daten enthalten sind, dann
End If
'eingetragene Daten in D loeschen
Range("D1:D" & iCnt) = ""
'String als Meldung ausgeben
MsgBox arrCodes
End Sub