Ich wurde gefragt, ob es eine Möglichkeit gibt, in Excel 500 Zufallscodes in einem Rutsch, bspw. für Kundenrabatte, nach Vorgaben zu generieren, die dann, über ein weiteres Script, in eine Datenbank eingespeist werden oder als Etikett ausgedruckt werden können. Ja – mit VBA kann man das machen.

Das hier gezeigte Script begrenzt sich auf das Erstellen der Zufallscodes.

Die Vorgaben waren Folgende:

• Die Anzahl der Zufallcodes sollte variabel sein
• Die Codes sollten aus Zufallszahlen und einer zufälligen Anordnung von Buchstaben bestehen
• Die Zufallcodes sollten aus 3 Gruppen zu je 5 Zeichen bestehen
• Als Buchstaben sollten nur Grossbuchstaben verwendet werden
• Die Zufallcodes sollten auf mehrere Spalten verteilt werden und die Anzahl der verwendeten Spalten sollte durch den Anwender festgelegt werden können
• Kein Zufallscode sollte doppelt vorkommen

Dieses Script generiert (mehr als) 500 Zufallcodes (3×5 Zeichen pro Zufallcode ) in einer Laufzeit < 1 Sekunde. Wenn man die Kommentare (Text nach den Hochkammata) entfernt, ist das Script relativ klein und übersichtlich. Kopieren Sie dieses Script in ein neues Modul, im VBA-Editor Ihrer Excel-Arbeitsmappe und klicken Sie in der Symbolleiste auf „Ausführen“ oder drücken Sie F5 auf Ihrer Tastatur um das Script zu testen.

Folgende Dinge sollte man bei Anwendung des Scriptes berücksichtigen:

• Dieses Script prüft nicht, ob eine zulässige Anzahl von Spalten als Vorgabe eingegeben wurde
  (Bei 500 Zufallcodes (50 Zeilen bei 10 Spalten) sollten 1.048.576 Zeilen und 16.384 Spalten ausreichen 😉
• Die Anzahl der verwendeten Zeilen ist durch die Auswahl der verwendeten Spalten abhängig und wird berechnet
• Das Script prüft nicht, ob die Tabelle1 vorhanden und/oder schreibgeschützt ist

Dieses Script kann u.a. auch verwendet/angepasst werden für:

• Rabattcodes
• Lizenzcodes
• Zufalls-Links oder Zufalls-Dateinamen
• Zufällige Passwörter generieren
• u.v.a. mehr…

Option Explicit
Option Base 1

Sub ZufallsCode()

    'Laufzeit des Makros bei 6500 Codes
    'und 3 x 5 Zeichen pro Code-Gruppe: < 1 Sekunde

    Dim i As Long, nTest As Long, n As Long, z As Long, s As Long, g As Boolean
    Dim nC As Long, nS As Long, nZ As Long, nGr As Long, nZn As Long, nR As Long
    Dim zufText As String, zufZahl As Long, OG As Byte, UG As Byte
    Dim arr_Code() As String
    
    nC = 300        'Anzahl Codes, die erstellt werden sollen
    nS = 10         'Anzahl der Spalten, die befüllt werden sollen
                    'die Zeilenanzahl wird berechnet!

    n = 1           'Start-Zähler
    zufZahl = 0     'Zufallszahl (Zahl)
    zufText = ""    'Zufallstext (String)
    OG = 10         'Obergrenze Zufallszahl
    UG = 0          'Untergrenze Zufallszahl
    
    'Prozedur nicht ausführen wenn die Eingaben = 0,
    'leer oder nicht numerisch sind
    If Not IsNumeric(nC) Or nC = 0 Then Exit Sub
    If Not IsNumeric(nS) Or nS = 0 Then Exit Sub
    
    'Abschalten, was bei der Erstellung
    'der Codes nicht benötigt wird:
    With Application
        .ScreenUpdating = False
        .Calculation = False
        .EnableEvents = False
    End With
    
    With ThisWorkbook.Sheets("Tabelle1")
        'Tabelle1 leeren
        .Cells.ClearContents
        'Zufallsgenerator initiieren
        Randomize
        
        'Schleife solange ausführen, bis n kleiner gleich Anzahl der Codes nC
        Do While n <= nC
            g = False
            'Anzahl der Gruppen je Zufalls-Code:
            For nGr = 1 To 3
                'Anzahl der Zeichen je Zufalls-Code-Gruppe:
                For nZn = 1 To 5
                    zufZahl = Int((OG - UG + 1) * Rnd + UG)
                    Select Case zufZahl
                        Case 4, 8
                            'zufällige Zahlen bilden:
                            zufText = zufText & Int((OG - 0) * Rnd + UG)
                        Case Else
                            'zufällige Buchstaben bilden:
                            zufZahl = Int((90 - 65 + 1) * Rnd + 65)
                            zufText = zufText & Chr(zufZahl)
                    End Select
                Next
                zufText = zufText & IIf(nGr < 3, "-", "")
            Next
            'den ersten Code ins Array eintragen
            'und danach alle Anderen auf Duplikate prüfen:
            If n = 1 Then
                ReDim arr_Code(n)
                arr_Code(n) = zufText
                zufText = ""
                n = n + 1
            Else
                'Einträge im Array auf Duplikate prüfen:
                For nTest = 1 To UBound(arr_Code)
                    If arr_Code(nTest) = zufText Then
                        g = True '< Eintrag bereits vorhanden
                        zufText = ""
                        Exit For
                    End If
                Next
                'Wenn der Zufallscode nicht im Array vorhanden ist,
                'wird er im Array eingetragen:
                If g = False Then
                    'Array um einen Eintrag vergrößern:
                    ReDim Preserve arr_Code(n)
                    'Den neuen Zufallscode dem Array hinzufügen:
                    arr_Code(n) = zufText
                    zufText = ""
                    n = n + 1
                End If
            End If
        Loop
        
        'Codes in Tabelle eintragen
        'Berechnung der notwendigen Zeilen:
        nR = nC \ nS
        nZ = nR + IIf(nC Mod nS > 0, 1, 0)
        'Zähler zurücksetzen (Option Base 1!):
        n = 1
        For s = 1 To nS '< erste Schleife für die zu befüllenden Spalten
            For z = 1 To nZ '< zweite Schleife für die berechnete Anzahl der Zeilen
                .Cells(z, s).Value = arr_Code(n) '< Zufallscode in Zelle eintragen
                If n < UBound(arr_Code) Then
                    n = n + 1
                Else
                    'Schleife verlassen wenn
                    'alle Codes eingetragen wurden:
                    Exit For
                End If
            Next z
        Next s
    End With

    'Alles wieder einschalten, was bei der Erstellung
    'der Codes abgeschaltet wurde:
    With Application
        .EnableEvents = True
        .Calculation = True
        .Calculate
        .ScreenUpdating = True
    End With

End Sub

Ich freue mich über Meinungen, Ideen oder Kritik… schreiben Sie mir eine E-Mail »