Office: (Office 2010) logische Unique-ID generieren

glegio · 18. September 2014

Hallo liebe Leute

Ich brauche dringend euer Rat, besser gesagt eure Hilfe.
Bin nicht der Excel-Spezialist und weis nicht recht ob für das Problem eher mit einer Formel oder mit VBA gelöst werden kann, resp. einfacher ist; ich versuche die Aufgabe zu erklären:

Die Lösung soll, eine Unique-ID aus Nach- und Vorname und eine Mail-Adresse generieren, folgendes muss jedoch berücksichtigt werden:
- ID darf keine Umlaute, Apostrophs etc. beinhalten und in Grossbuchstabe sein
- Mailadresse darf keine Umlaute, Apostrophs etc. beinhalten und in Kleinbuchstabe sein
- Je nach User-Kategorie soll die ID entsprechend generiert werden
- ID muss immer 7-stellig sein und mit einem Präfix pro Kategorie anfangen: z.B. „XX00“ für Kategorie 1 und „XX10“ für Kategorie 2, anschliessend erste und letzter Buchstabe des Nachnamens und erste Buchstabe Vorname
Beispiel für Müller Max Kat 1: XX00MRM
Beispiel für Meier Martin Kat 2: XX10MRM
- Wenn eine ID bereits existiert, dann erste und 2-letzter Buchstabe des Nachnamens, ..3.-letzter, ..4.-letzter, usw., wenn keine Möglichkeit besteht,
Beispiel für Müller Max Kat 1: XX00MRM
Beispiel für Meier Martin Kat 1: XX00MEM .. Meier Martin XX00MIM usw.
- Wenn alle Kombinationen ausgeschöpft sind, soll Präfix für Kat. 1 „XX01“ werden
- Und Präfix für Kat 2 „XX11“ werden

Das Excel-File sieht wie folgt aus:
Tabelle 1 Spalte A: Kategorie
Tabelle 1 Spalte B: Nachname
Tabelle 1 Spalte C: Vorname
Tabelle 2 beinhaltet alle bereits existierende ID in Spalte D und Mailadresse in Spalte E, welche natürlich ebenfalls berücksichtigt werden sollen.

Die Lösung soll dann in Tabelle 1 Spalte D die ID schreiben und in Spalte E die Mailadresse welche ebenfalls auf Eindeutigkeit geprüft werden sollen.
Ergeben sich bei den Mailadressen doppelwerte, sollen diese in Spalte F gekennzeichnet werden.

Ich lege ein Beispiel-File bei, für besseres Verständnis.

Im Voraus schon vielen herzlichen Dank

:)

xlph · 21. September 2014

Hallo,

eine VBA-Lösung:

Code:

Sub ID_Email_Generieren()
Dim Daten As Variant
Dim lngD As Long

Dim Kat As Long
Dim Nachname As String
Dim Vorname As String

Dim KatZ As Long

Dim IDs As Variant
Dim EMails As Variant
Dim Pruefungen As Variant
Dim lngI As Long

Dim PrufungZ As Long

Dim ID_Zeichen1 As String
Dim ID_Zeichen2 As String
Dim ID_Zeichen3 As String
Dim ID_Neu As Boolean

Dim ID As String
Dim EMail As String

Dim dicID As Object
Dim dicEMail As Object

Dim Abbruch As Boolean

Set dicID = CreateObject("scripting.dictionary")
Set dicEMail = CreateObject("scripting.dictionary")

With Tabelle1

Daten = .Range("A1").CurrentRegion.Resize(, 3).Value

ReDim IDs(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim EMails(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim Pruefungen(LBound(Daten) To UBound(Daten), 1 To 1)

For lngD = LBound(Daten) + 1 To UBound(Daten)

Kat = Daten(lngD, 1)
Nachname = Daten(lngD, 2)
Vorname = Daten(lngD, 3)

KatZ = IIf(Kat = 1, 0, 10)

Nachname = UmlauteUmwandeln(Nachname)
Vorname = UmlauteUmwandeln(Vorname)

ID_Zeichen1 = UCase$(Left$(Nachname, 1))
ID_Zeichen3 = UCase$(Left$(Vorname, 1))

Do
ID_Neu = False

For lngI = Len(Nachname) To 2 Step -1
ID_Zeichen2 = UCase$(Mid$(Nachname, lngI, 1))
ID = Format(KatZ, "XX00") & ID_Zeichen1 & ID_Zeichen2 & ID_Zeichen3
If Not dicID.Exists(ID) Then
dicID(ID) = Empty
ID_Neu = True
Exit For
End If
Next

If ID_Neu Then
Exit Do
Else
KatZ = KatZ + 1
Select Case Kat
Case 1: If KatZ >= 10 Then Abbruch = True: Exit Do
Case 2: If KatZ >= 100 Then Abbruch = True: Exit Do
End Select
End If
Loop

EMail = LCase$(Vorname & "." & Nachname & "@" & "domain.xx")

If Abbruch Then
MsgBox "Kategorie" & Kat & "-Präfixe vollens erschöpft!" & vbLf & _
"Es wird abgebrochen!": End
Exit For
End If

IDs(lngD, 1) = ID
EMails(lngD, 1) = EMail

If dicEMail.Exists(EMail) Then
Pruefungen(lngD, 1) = dicEMail(EMail)
Pruefungen(dicEMail(EMail), 1) = dicEMail(EMail)
Else
dicEMail(EMail) = lngD
End If

Next

.Range("D1").Resize(UBound(IDs)).Value = IDs
.Range("E1").Resize(UBound(EMails)).Value = EMails
.Range("F1").Resize(UBound(Pruefungen)).Value = Pruefungen

End With

Set dicID = Nothing
Set dicEMail = Nothing

End Sub

Public Function UmlauteUmwandeln(Wert As String) As String
Dim I As Long, Zeichen As String

For I = 1 To Len(Wert)
Zeichen = Mid$(Wert, I, 1)
Select Case Zeichen
Case "a" To "z", "-", "A" To "Z":
UmlauteUmwandeln = UmlauteUmwandeln & Zeichen
Case "ß": UmlauteUmwandeln = UmlauteUmwandeln & "ss"
Case "ä": UmlauteUmwandeln = UmlauteUmwandeln & "ae"
Case "ö": UmlauteUmwandeln = UmlauteUmwandeln & "oe"
Case "ü": UmlauteUmwandeln = UmlauteUmwandeln & "ue"
Case "Ä": UmlauteUmwandeln = UmlauteUmwandeln & "Ae"
Case "Ö": UmlauteUmwandeln = UmlauteUmwandeln & "Oe"
Case "Ü": UmlauteUmwandeln = UmlauteUmwandeln & "Ue"
End Select
Next
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

glegio · 21. September 2014

Vielen herzlichen Dank Xlph!!
Die Lösung ist genial, weiss gar nicht wie mich bedanke.

Kannst Du mir bitte sagen wie ich das Präfix ändern kann ..habe mir der VBA-Code angeschaut und versucht das "XX00" abzuändern, ging jedoch voll in Hosen.
Das gleiche gilt auch für die Kategorien 1 und 2, ansonsten echt super!!

glegio

xlph · 21. September 2014

Hallo,

Code:

Sub ID_Email_Generieren()
Dim Daten As Variant
Dim lngD As Long

Dim Kat As Long
Dim Nachname As String
Dim Vorname As String

Dim KatZ As Long

Dim IDs As Variant
Dim EMails As Variant
Dim Pruefungen As Variant
Dim lngI As Long

Dim PrufungZ As Long

Dim ID_Zeichen1 As String
Dim ID_Zeichen2 As String
Dim ID_Zeichen3 As String
Dim ID_Neu As Boolean

Dim ID As String
Dim EMail As String

Dim dicID As Object
Dim dicEMail As Object

Dim Abbruch As Boolean

Dim colKategorie As Collection

Const cPraefix As String = "XX" ' ggf. Anpassen *****

Set colKategorie = New Collection

' Item=> Präfixzähler, Key=> Kategorie
colKategorie.Add Item:=0, Key:=CStr(1) ' ggf. Anpassen *****
colKategorie.Add Item:=10, Key:=CStr(2) ' ggf. Anpassen *****

Set dicID = CreateObject("scripting.dictionary")
Set dicEMail = CreateObject("scripting.dictionary")

With Tabelle1

Daten = .Range("A1").CurrentRegion.Resize(, 3).Value

ReDim IDs(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim EMails(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim Pruefungen(LBound(Daten) To UBound(Daten), 1 To 1)

For lngD = LBound(Daten) + 1 To UBound(Daten)

Kat = Daten(lngD, 1)
Nachname = Daten(lngD, 2)
Vorname = Daten(lngD, 3)

If CollectionKeyExist(colKategorie, CStr(Kat)) Then

KatZ = colKategorie(CStr(Kat))

Nachname = UmlauteUmwandeln(Nachname)
Vorname = UmlauteUmwandeln(Vorname)

ID_Zeichen1 = UCase$(Left$(Nachname, 1))
ID_Zeichen3 = UCase$(Left$(Vorname, 1))

Do
ID_Neu = False

For lngI = Len(Nachname) To 2 Step -1
ID_Zeichen2 = UCase$(Mid$(Nachname, lngI, 1))
ID = cPraefix & Format(KatZ, "00") & ID_Zeichen1 & ID_Zeichen2 & ID_Zeichen3
If Not dicID.Exists(ID) Then
dicID(ID) = Empty
ID_Neu = True
Exit For
End If
Next

If ID_Neu Then
Exit Do
Else
KatZ = KatZ + 1
Select Case Kat
Case 1: If KatZ >= 10 Then Abbruch = True: Exit Do
Case 2: If KatZ >= 100 Then Abbruch = True: Exit Do
End Select
End If
Loop

EMail = LCase$(Vorname & "." & Nachname & "@" & "domain.xx")

If Abbruch Then
MsgBox "Kategorie" & Kat & "-Präfixe vollens erschöpft!" & vbLf & _
"Es wird abgebrochen!": End
Exit For
End If

IDs(lngD, 1) = ID
EMails(lngD, 1) = EMail

If dicEMail.Exists(EMail) Then
Pruefungen(lngD, 1) = dicEMail(EMail)
Pruefungen(dicEMail(EMail), 1) = dicEMail(EMail)
Else
dicEMail(EMail) = lngD
End If

End If
Next

.Range("D1").Resize(UBound(IDs)).Value = IDs
.Range("E1").Resize(UBound(EMails)).Value = EMails
.Range("F1").Resize(UBound(Pruefungen)).Value = Pruefungen

End With

Set colKategorie = Nothing
Set dicID = Nothing
Set dicEMail = Nothing

End Sub

Public Function UmlauteUmwandeln(Wert As String) As String
Dim I As Long, Zeichen As String

For I = 1 To Len(Wert)
Zeichen = Mid$(Wert, I, 1)
Select Case Zeichen
Case "a" To "z", "-", "A" To "Z":
UmlauteUmwandeln = UmlauteUmwandeln & Zeichen
Case "ß": UmlauteUmwandeln = UmlauteUmwandeln & "ss"
Case "ä": UmlauteUmwandeln = UmlauteUmwandeln & "ae"
Case "ö": UmlauteUmwandeln = UmlauteUmwandeln & "oe"
Case "ü": UmlauteUmwandeln = UmlauteUmwandeln & "ue"
Case "Ä": UmlauteUmwandeln = UmlauteUmwandeln & "Ae"
Case "Ö": UmlauteUmwandeln = UmlauteUmwandeln & "Oe"
Case "Ü": UmlauteUmwandeln = UmlauteUmwandeln & "Ue"
End Select
Next
End Function

Public Function CollectionKeyExist(ByRef colData As Collection, ByVal strKey As String) As Boolean
On Error Resume Next
CollectionKeyExist = (VarType(colData(strKey)) > -1)
On Error GoTo 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

glegio · 12. Januar 2021

von xlph

Hallo,

Code:
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Sub ID_Email_Generieren()
Dim Daten As Variant
Dim lngD As Long

Dim Kat As Long
Dim Nachname As String
Dim Vorname As String

Dim KatZ As Long

Dim IDs As Variant
Dim EMails As Variant
Dim Pruefungen As Variant
Dim lngI As Long

Dim PrufungZ As Long

Dim ID_Zeichen1 As String
Dim ID_Zeichen2 As String
Dim ID_Zeichen3 As String
Dim ID_Neu As Boolean

Dim ID As String
Dim EMail As String

Dim dicID As Object
Dim dicEMail As Object

Dim Abbruch As Boolean

Dim colKategorie As Collection

Const cPraefix As String = "XX" ' ggf. Anpassen *****

Set colKategorie = New Collection

' Item=> Präfixzähler, Key=> Kategorie
colKategorie.Add Item:=0, Key:=CStr(1) ' ggf. Anpassen *****
colKategorie.Add Item:=10, Key:=CStr(2) ' ggf. Anpassen *****

Set dicID = CreateObject("scripting.dictionary")
Set dicEMail = CreateObject("scripting.dictionary")

With Tabelle1

Daten = .Range("A1").CurrentRegion.Resize(, 3).Value

ReDim IDs(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim EMails(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim Pruefungen(LBound(Daten) To UBound(Daten), 1 To 1)

For lngD = LBound(Daten) + 1 To UBound(Daten)

Kat = Daten(lngD, 1)
Nachname = Daten(lngD, 2)
Vorname = Daten(lngD, 3)

If CollectionKeyExist(colKategorie, CStr(Kat)) Then

KatZ = colKategorie(CStr(Kat))

Nachname = UmlauteUmwandeln(Nachname)
Vorname = UmlauteUmwandeln(Vorname)

ID_Zeichen1 = UCase$(Left$(Nachname, 1))
ID_Zeichen3 = UCase$(Left$(Vorname, 1))

Do
ID_Neu = False

For lngI = Len(Nachname) To 2 Step -1
ID_Zeichen2 = UCase$(Mid$(Nachname, lngI, 1))
ID = cPraefix & Format(KatZ, "00") & ID_Zeichen1 & ID_Zeichen2 & ID_Zeichen3
If Not dicID.Exists(ID) Then
dicID(ID) = Empty
ID_Neu = True
Exit For
End If
Next

If ID_Neu Then
Exit Do
Else
KatZ = KatZ + 1
Select Case Kat
Case 1: If KatZ >= 10 Then Abbruch = True: Exit Do
Case 2: If KatZ >= 100 Then Abbruch = True: Exit Do
End Select
End If
Loop

EMail = LCase$(Vorname & "." & Nachname & "@" & "domain.xx")

If Abbruch Then
MsgBox "Kategorie" & Kat & "-Präfixe vollens erschöpft!" & vbLf & _
"Es wird abgebrochen!": End
Exit For
End If

IDs(lngD, 1) = ID
EMails(lngD, 1) = EMail

If dicEMail.Exists(EMail) Then
Pruefungen(lngD, 1) = dicEMail(EMail)
Pruefungen(dicEMail(EMail), 1) = dicEMail(EMail)
Else
dicEMail(EMail) = lngD
End If

End If
Next

.Range("D1").Resize(UBound(IDs)).Value = IDs
.Range("E1").Resize(UBound(EMails)).Value = EMails
.Range("F1").Resize(UBound(Pruefungen)).Value = Pruefungen

End With

Set colKategorie = Nothing
Set dicID = Nothing
Set dicEMail = Nothing

End Sub

Public Function UmlauteUmwandeln(Wert As String) As String
Dim I As Long, Zeichen As String

For I = 1 To Len(Wert)
Zeichen = Mid$(Wert, I, 1)
Select Case Zeichen
Case "a" To "z", "-", "A" To "Z":
UmlauteUmwandeln = UmlauteUmwandeln & Zeichen
Case "ß": UmlauteUmwandeln = UmlauteUmwandeln & "ss"
Case "ä": UmlauteUmwandeln = UmlauteUmwandeln & "ae"
Case "ö": UmlauteUmwandeln = UmlauteUmwandeln & "oe"
Case "ü": UmlauteUmwandeln = UmlauteUmwandeln & "ue"
Case "Ä": UmlauteUmwandeln = UmlauteUmwandeln & "Ae"
Case "Ö": UmlauteUmwandeln = UmlauteUmwandeln & "Oe"
Case "Ü": UmlauteUmwandeln = UmlauteUmwandeln & "Ue"
End Select
Next
End Function

Public Function CollectionKeyExist(ByRef colData As Collection, ByVal strKey As String) As Boolean
On Error Resume Next
CollectionKeyExist = (VarType(colData(strKey)) > -1)
On Error GoTo 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

hallo xlph
Nochmals vielen Dank für deine wertvolle Hilfe.
Konnte es nur heute testen und war leider nur mit Anpassen des Präfix erfolgreich und auch das nur teilweise, wenn die Kat. anstelle einer Zahl ein Buchstabe ist erhalte ich Laufzeitfehler '457'.
Ich möchte konkret die Kategorien in "I" und "E" ändern und dann wenn Kat. I =Präfix "CH00" wenn Kat. E = Präfix "CHE0"
Kannst Du mir einen letzten Hinweis geben, denke dann ist definitiv o.k.
Danke glegio

xlph · 1. Oktober 2014

Hallo,

Code:

Sub ID_Email_Generieren()
Dim Daten As Variant
Dim lngD As Long

Dim Kat As String
Dim Nachname As String
Dim Vorname As String

Dim KatZ As Long

Dim IDs As Variant
Dim EMails As Variant
Dim Pruefungen As Variant
Dim lngI As Long

Dim PrufungZ As Long

Dim ID_Zeichen1 As String
Dim ID_Zeichen2 As String
Dim ID_Zeichen3 As String
Dim ID_Neu As Boolean

Dim ID As String
Dim EMail As String

Dim dicID As Object
Dim dicEMail As Object

Dim Abbruch As Boolean

Dim colKategorie As Collection

Const cPraefix As String = "CH" ' ggf. Anpassen *****

Set colKategorie = New Collection

' Item=> Präfixzähler, Key=> Kategorie
colKategorie.Add Item:=0, Key:="E" ' ggf. Anpassen *****
colKategorie.Add Item:=10, Key:="I" ' ggf. Anpassen *****

Set dicID = CreateObject("scripting.dictionary")
Set dicEMail = CreateObject("scripting.dictionary")

With Tabelle1

Daten = .Range("A1").CurrentRegion.Resize(, 3).Value

ReDim IDs(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim EMails(LBound(Daten) To UBound(Daten), 1 To 1)
ReDim Pruefungen(LBound(Daten) To UBound(Daten), 1 To 1)

For lngD = LBound(Daten) + 1 To UBound(Daten)

Kat = Daten(lngD, 1)
Nachname = Daten(lngD, 2)
Vorname = Daten(lngD, 3)

If CollectionKeyExist(colKategorie, CStr(Kat)) Then

KatZ = colKategorie(CStr(Kat))

Nachname = UmlauteUmwandeln(Nachname)
Vorname = UmlauteUmwandeln(Vorname)

ID_Zeichen1 = UCase$(Left$(Nachname, 1))
ID_Zeichen3 = UCase$(Left$(Vorname, 1))

Do
ID_Neu = False

For lngI = Len(Nachname) To 2 Step -1
ID_Zeichen2 = UCase$(Mid$(Nachname, lngI, 1))
ID = ID_Zeichen1 & ID_Zeichen2 & ID_Zeichen3

Select Case CStr(Kat)
Case "E": ID = cPraefix & "E" & Format(KatZ, "0") & ID ' ggf. Anpassen *****
Case "I": ID = cPraefix & Format(KatZ, "00") & ID ' ggf. Anpassen *****
End Select

If Not dicID.Exists(ID) Then
dicID(ID) = Empty
ID_Neu = True
Exit For
End If
Next

If ID_Neu Then
Exit Do
Else
KatZ = KatZ + 1
Select Case Kat
Case "E": If KatZ > 10 Then Abbruch = True: Exit Do ' ggf. Anpassen *****
Case "I": If KatZ > 100 Then Abbruch = True: Exit Do ' ggf. Anpassen *****
End Select
End If
Loop

EMail = LCase$(Vorname & "." & Nachname & "@" & "domain.xx")

If Abbruch Then
MsgBox "Kategorie" & Kat & "-Präfixe vollens erschöpft!" & vbLf & _
"Es wird abgebrochen!": End
Exit For
End If

IDs(lngD, 1) = ID
EMails(lngD, 1) = EMail

If dicEMail.Exists(EMail) Then
Pruefungen(lngD, 1) = dicEMail(EMail)
Pruefungen(dicEMail(EMail), 1) = dicEMail(EMail)
Else
dicEMail(EMail) = lngD
End If

End If
Next

.Range("D1").Resize(UBound(IDs)).Value = IDs
.Range("E1").Resize(UBound(EMails)).Value = EMails
.Range("F1").Resize(UBound(Pruefungen)).Value = Pruefungen

End With

Set colKategorie = Nothing
Set dicID = Nothing
Set dicEMail = Nothing

End Sub

Public Function UmlauteUmwandeln(Wert As String) As String
Dim I As Long, Zeichen As String

For I = 1 To Len(Wert)
Zeichen = Mid$(Wert, I, 1)
Select Case Zeichen
Case "a" To "z", "-", "A" To "Z":
UmlauteUmwandeln = UmlauteUmwandeln & Zeichen
Case "ß": UmlauteUmwandeln = UmlauteUmwandeln & "ss"
Case "ä": UmlauteUmwandeln = UmlauteUmwandeln & "ae"
Case "ö": UmlauteUmwandeln = UmlauteUmwandeln & "oe"
Case "ü": UmlauteUmwandeln = UmlauteUmwandeln & "ue"
Case "Ä": UmlauteUmwandeln = UmlauteUmwandeln & "Ae"
Case "Ö": UmlauteUmwandeln = UmlauteUmwandeln & "Oe"
Case "Ü": UmlauteUmwandeln = UmlauteUmwandeln & "Ue"
End Select
Next
End Function

Public Function CollectionKeyExist(ByRef colData As Collection, ByVal strKey As String) As Boolean
On Error Resume Next
CollectionKeyExist = (VarType(colData(strKey)) > -1)
On Error GoTo 0
End Function
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

glegio · 4. Oktober 2014

Vielen Dank lieber xlph, Du warst mir eine sehr grosse Hilfe!!

Office: (Office 2010) logische Unique-ID generieren

logische Unique-ID generieren

logische Unique-ID generieren

logische Unique-ID generieren

logische Unique-ID generieren - Similar Threads - logische Unique generieren

Logische Funktionen (Referenz)

Video: Verwenden von logischen Operatoren und Platzhaltern in Parameterabfragen

Video: Verwenden von logischen Operatoren und Platzhaltern in einer Access-App

Selbstständige, logische Übernahme von Formeln

logische Vergleichsoperation OR / AND

Excelspalte in mehrere Spalten logisch umsortieren

Logische Verknüpfung zwischen 2 Tabellen