Creazione codice alfanumerico casuale

Question

Buona sera a tutti,

per un contest avrei bisogno di creare dei codici alfanumerici (misti) di 5 o 6 digit che non si ripetano mai e che restino invariati nel tempo.

una cosa del tipo:

J85RF

48RH2

FK394

non riesco a trovare una funzione in excel che mi possa aiutare...Qualcuno mi sa aiutare?

Grazie

Mirko

Answer 1

Ciao Mirko,

per un contest avrei bisogno di creare dei codici alfanumerici (misti) di 5 o 6 digit che non si ripetano mai e che restino invariati nel tempo.

una cosa del tipo:

J85RF

48RH2

FK394

non riesco a trovare una funzione in excel che mi possa aiutare...Qualcuno mi sa aiutare?

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IM per inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim oDic As Object

    Dim WB As Workbook

    Dim destSH As Worksheet

    Dim destRng As Range

    Dim arrKeys As Variant, arrOut() As Variant

    Dim sCodice As String

    Dim i As Long, j As Long, k As Long

    Dim iCtr As Long, jCtr As Long

    Const sAlphaNumeric As String = _

          "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"

    Const sFoglio As String = "ElencoCodice"

    Const iLenCodice As Long = 5                     '<<=== Modifica

    Const iNumeroDiCodici As Long = 10000     '<<=== Modifica

    Set WB = ThisWorkbook

    With WB

        If SheetExists(sFoglio) Then

            Set destSH = .Sheets(sFoglio)

            destSH.Columns("A").ClearContents

        Else

            Set destSH = .Sheets.Add(Before:=Sheets(1))

            destSH.Name = sFoglio

        End If

    End With

    destSH.Range("A1").Value = "CODICE"

    Randomize

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        Do While iCtr < iNumeroDiCodici

            sCodice = vbNullString

            For j = 1 To iLenCodice

                sCodice = sCodice & Mid$(sAlphaNumeric, _

                        Int(Rnd() * Len(sAlphaNumeric) + 1), 1)

            Next j

            If Not .Exists(sCodice) Then

                iCtr = iCtr + 1

                .Add Key:=sCodice, Item:=Nothing

            End If

        Loop

        arrKeys = .keys

        jCtr = .Count

    End With

    ReDim arrOut(1 To jCtr, 1 To 1)

    For k = 1 To iCtr

        arrOut(k, 1) = arrKeys(k - 1)

    Next k

    On Error GoTo XIT

    Application.ScreenUpdating = False

    destSH.Range("A2").Resize(iNumeroDiCodici).Value = arrOut

        Call MsgBox( _

             Prompt:="Finito!" _

             & vbNewLine & vbNewLine _

             & jCtr & " codici alfanumerici, univoci e  di lunghezza " _

             & iLenCodice & " sono stati copiati nella colonna A " _

             & "del foglio " & sFoglio, _

             Buttons:=vbInformation, _

             Title:="REPORT")

XIT:

    Set oDic = Nothing

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function SheetExists(sSheetName As String, _

                            Optional ByVal WB As Workbook) As Boolean

    On Error Resume Next

    If WB Is Nothing Then

        Set WB = ThisWorkbook

    End If

    SheetExists = CBool(Len(WB.Sheets(sSheetName).Name))

    On Error GoTo 0

End Function

'<<========= 

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester
• Esegui

Per cambiare la lunghezza dei codici, sostituisci il valore 5 assegnato alla costante iLenCodicecon la lunghezza voluta.

Per cambiare il numero di codici elencati nella colonna A del foglio ElencoCodice, modifica il valore 10000 assegnato alla costante iNumeroDiCodici.

Potresti scaricare il mio file di prova Mirko20180503.xlsm

===

Regards,

Norman

Answer 2

Ciao Mirko,

Grazie infinite, era esattamente quello checercavo e di cui aveva bisogno!

Mi fa piacere che tu abbia risolto il problema e ti ringrazio per il cortese riscontro.

Per chiudere questo thread, vorrei chiederti gentilmente di controllare l'opzione Contrassegna come risposta dal menu a discesa - Strumenti avanzati, sotto la rispettiva risposta.

In questo modo, le risposte convalidate saranno promosse immediatamente al di sotto della domanda iniziale, e tutti gli altri lettori che hanno la stessa preoccupazione , saranno in grado di trovare più facilmente la risposta, durante la loro ricerca nel nostro forum e su internet.

===

Regards,

Norman 

Answer 3

Ciao Norman,

Grazie infinite, era esattamente quello checercavo e di cui aveva bisogno!

Mirko