GENERAR CADENA DE CARACTERES ALFANUMÉRICOS ALEATORIOS SIN DUPLICADOS

Hola todos!

Hace unos meses publiqué un post acerca de la generación de números aleatorios sin duplicados:  OBTENER NÚMEROS ALEATORIOS SIN DUPLICADOS

El código funciona perfectamente y muchos lectores lo han descargado para usarlo en sus aplicaciones. Sin embargo, ayer un usuario me consultaba si podría modificarlo para generar una cadena alfanumérica aleatoria sin duplicados.

La respuesta es que sí, veamos el código y las modificaciones realizadas:

Option Explicit
Sub OBTENER_CADENA_ALEATORIOS_UNICOS()
'Declaramos variables
Dim oDic As Object, palabra As Variant
Dim Micelda As String, matrix1 As Variant, matrix2 As Variant
Dim sCadena As String, i As Integer, unicos As String
Dim j As Integer, nNum As Double, fin As Integer
Dim nLetU As String, nLetL As String, nItem As Variant, nCombo As Integer
With Sheets("Hoja1")
'eliminamos información generada en la consulta anterior.
fin = .Range("A2", .Range("A" & .Rows.Count).End(xlUp)).Rows.Count
.Range("A2:A" & 2 + fin).ClearContents
'Creamos objeto diccionario
Set oDic = CreateObject("scripting.dictionary")
'Ejecutamos loop hasta el total de números y letras que queremos obtener
Do Until j = .Cells(2, 6)
'generamos aleatorios entre 1 y 50
nNum = Application.WorksheetFunction.RandBetween(.Cells(4, 6), .Cells(4, 7))
'generamos aleatorio de letras mayúsculas
nLetU = Chr((Application.WorksheetFunction.RandBetween(65, 90)))
'generamos aleatorio de letras minúsculas
nLetL = LCase(Chr((Application.WorksheetFunction.RandBetween(65, 90))))
'determinamos aleatoriamente qué elemento seleccionamos para pasar a la cadena
nCombo = Application.WorksheetFunction.RandBetween(1, 3)
If nCombo = 1 Then
nItem = nNum
ElseIf nCombo = 2 Then
nItem = nLetU
ElseIf nCombo = 3 Then
nItem = nLetL
End If
'componemos string con los números y letras que vamos generando
Micelda = Micelda & " " & nItem
matrix1 = Split(Micelda, " ")
'Eliminamos números y letras repetidos
For i = 0 To UBound(matrix1)
If Not oDic.Exists(matrix1(i)) Then oDic.Add matrix1(i), matrix1(i)
Next i
'Creamos una nueva cadena sin duplicados y seguimos el loop
unicos = Join(oDic.Keys, " ")
sCadena = Trim(unicos)
matrix2 = Split(sCadena, " ")
'contamos los números y letras aleatorios únicos que vamos generando
j = UBound(matrix2) + 1
Loop
'Pasamos los datos a la hoja1
matrix2 = Split(sCadena, " ")
For j = 0 To UBound(matrix2)
.Cells(j + 2, 1) = matrix2(j)
Next j
End With
'Vaciamos variable de objeto
Set oDic = Nothing
End Sub

Para poder generar aleatorios de letras, necesitamos recurrir a los caracteres ASCII, en concreto vamos a utilizar los que van desde el 65 al 90, que comprenden el abecedario en mayúsculas. Luego solo tenemos que introducir la función aleatorio.entre y tendremos una variable que generará una letra de forma aleatoria cada vez que se ejecute el código:

nLetU = Chr((Application.WorksheetFunction.RandBetween(65, 90)))

Para realizar lo mismo en minúsculas, solo tenemos que transformar esta información con LCase:

nLetL = LCase(Chr((Application.WorksheetFunction.RandBetween(65, 90))))

Luego, con un pequeño condicional y otra variable aleatoria entre 1 y 3, iremos componiendo nuestra cadena alfanumérica aleatoriamente, y con el objeto dictionary eliminaremos los duplicados.

El resultado, por ejemplo, generando una cadena de 25 caracteres con números comprendidos del 1 al 9, sería este:

GENERAR CADENA DE CARACTERES ALFANUMERICOS ALEATORIOS SIN DUPLICADOS

Como podéis observar la información se obtiene perfectamente. Aunque es obvio, lo comentaré, las letras mayúsculas y minúsculas se tratan como si fuesen caracteres diferentes, por ello pueden existir tanto una “M” mayúscula como una “m” minúscula.

Y eso es todo, espero que resulte de utilidad : )

Descarga el archivo de ejemplo pulsando en: GENERAR CADENA DE CARACTERES ALFANUMÉRICOS ALEATORIOS SIN DUPLICADOS

¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.

Donate Button with Credit Cards

¡¡Muchas gracias!!

Anuncios

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MÁS CARACTERES

Hola a todos:

Hace unos días me llegó una consulta donde solicitaban extraer información de una cadena de datos. Sobre esta temática hay varios post dedicados en la web 🙂

Aquí lo que me pedían era el modo de extraer datos de dos en dos y pasarlos a columnas contiguas. Es un trabajo sencillo pero requiere modificar la macro desarrollada en este post: EXTRAER INFORMACIÓN ESPECÍFICA DE UNA CADENA ALFANUMÉRICA UTILIZANDO TEXTO EN COLUMNAS

Realmente lo que vamos a necesitar es fragmentar esa cadena de datos de dos en dos y con un espacio entre cada par de números, para luego utilizar texto en columnas y separar por espacios.

Pues bien, vamos a utilizar este ejemplo:

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES

en este caso trabajamos con datos numéricos y formato numérico, pero funciona perfectamente para texto. Y utilizaremos la siguiente macro:

Sub Extrae_n_caracteres()
'Definimos variables
Dim i As Integer, j As Integer, n As Integer, fin As Integer
Dim nCampos As Integer, n_Colum As Integer
Dim miCelda As String, sCadena As String, nPar As String
Dim miArray As Variant, iArray As Variant
'Iniciamos la macro
With Sheets("DATOS")
Application.ScreenUpdating = False
fin = Application.CountA(.Range("A:A"))
'Borramos información a partir de la columna "B"
.Range(.Cells(2, 2), ActiveCell.SpecialCells(xlLastCell)).Select
Selection.ClearContents
'Iniciamos bucle para recorrar todas las filas
For j = 2 To fin
sCadena = vbNullString
miCelda = .Cells(j, 1)
'Vaciamos variable scadena
For i = 1 To Len(miCelda) Step 2
'Extraemos de 2 en 2
nPar = Mid(miCelda, i, 2)
'Añadimos un espacio cada dos números
sCadena = sCadena & " " & nPar
Next
'Eliminamos espacios al principio y final
miCelda = Trim(sCadena)
'Pasamos la cadena a la segunda columna
.Cells(j, 2) = Trim(sCadena)
'Dimensionamos matrices con los datos que tenemos en miCelda
'para determinar las columnas de la función textToColumns
nCampos = Len(.Cells(j, 2))
nCampos = nCampos - 1
ReDim miArray(0 To nCampos)
For n_Colum = 0 To nCampos
ReDim iArray(0 To 1)
iArray(0) = n_Colum + 1
iArray(1) = 2
miArray(n_Colum) = iArray
Next n_Colum
'Aplicamos la función texto en columnas a partir de la segunda columna
'delimitamos el texto en caracteres (en este ejemplo utilizamos los espacios).
Cells(j, 2).TextToColumns Destination:=Range("B" & j), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Space:=True, FieldInfo:=miArray
'Indicamos que todas las matrices tengan formato general, pero podríamos indicar que sea número, etc
Next
.Cells(j, 1).Select
End With
End Sub

El resultado será el siguiente:

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES2

Podríamos modificar los parámetros para extraer de tres en tres: modificando los parámetros de la macro (en rojo)

For i = 1 To Len(miCelda) Step 3
'Extraemos de 3 en 3
nPar = Mid(miCelda, i, 3)
'Añadimos un espacio cada tres números
sCadena = sCadena & " " & nPar
Next

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES3

o de cuatro en cuatro:

For i = 1 To Len(miCelda) Step 4
'Extraemos de 4 en 4
nPar = Mid(miCelda, i, 4)
'Añadimos un espacio cada tres números
sCadena = sCadena & " " & nPar
Next

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES4

Incluso podríamos extraer cada n posiciones repitiendo el último número del fragmento anterior:

For i = 1 To Len(miCelda) Step 1
'Extraemos de 2 en 2 y añadiendo en número del fragmento anterior
nPar = Mid(miCelda, i, 2)
'Añadimos un espacio cada dos números
sCadena = sCadena & " " & nPar
Next

EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES5

Y este ha sido el resultado de la consulta, que le sirvió a nuestro lector perfectamente para seguir con su proyecto 🙂

Espero que os sea de utilidad también a vosotros.

Descarga el archivo de ejemplo pulsando en: EXTRAER DATOS DE UNA CADENA DE TEXTO DE DOS EN DOS O MAS CARACTERES

 
¿Te ha resultado de interés?, puedes apoyar a Excel Signum con una pequeña donación.

Donate Button with Credit Cards

¡¡Muchas gracias!!