Generando el mismo número aleatorio máximo 6 veces vba

Mi problema es que estoy tratando de hacer una serie de numbers aleatorios, digamos entre 1-10 y estos numbers se extenderán como 50 publicaciones y el mismo número aleatorio solo puede ocurrir un máximo de 6 veces.

(Editado)

Mi código actual está escrito que cuento las filas con un valor dividido en 6 para determinar cuántos numbers aleatorios diferentes necesito. Si las 58 celdas tienen valor, necesito numbers aleatorios entre 1-10. Creo que las Filas máximas que necesito serán 200

Dim i As Integer Dim a As Integer a1 = ActiveSheet.UsedRange.Rows.Count Range("E1") = a1 For i = 1 To a1 MinNumber = 1 MaxNumber = a1 / 6 Range("D1") = MaxNumber Cells(i, 1).Value = Int((Rnd * (MaxNumber - MinNumber + 1)) + MinNumber) Next i 

Este código usa un dictionary para ingresar el range inicial de numbers requeridos y luego eliminarlos uno por uno.

 Sub Recut() Dim a As Long Dim objDic As Object Dim lngCnt As Long Dim lngCnt2 As Long Dim lngCnt3 As Long Dim lngTot As Long Dim lngOut As Long Dim lngNum As Long lngTot = Application.InputBox("Input number of items to generate", , ActiveSheet.UsedRange.Rows.Count) Set objDic = CreateObject("scripting.dictionary") MinNumber = 1 MaxNumber = Int(lngTot / 6) + 1 For lngCnt = 1 To 6 For lngCnt2 = 1 To MaxNumber lngCnt3 = lngCnt3 + 1 objDic.Add lngCnt2 & "|" & lngCnt, lngCnt3 Next Next For lngOut = 1 To a lngNum = Int(Rnd() * objDic.Count) Cells(lngOut, 1) = Application.Index(Split(objDic.Keys(lngNum), "|"), 1) objDic.Remove objDic.Keys(lngNum) Next End Sub 

La siguiente es una versión de su código que usará una matriz. Tenga en count que dijo que un máximo de 200 filas, así que tenga cuidado si es> 200. Si el mismo número se generó más de 6 veces, entonces encontrará una alternativa. Puede eliminar Debug.Print 'si es molesto.

 Option Explicit Sub Random_Numbers() Dim i As Integer Dim a As Integer Dim lLastRow As Long Dim MinNumber As Long Dim MaxNumber As Long Dim lRndNbr As Long Dim aLimitTo6(200) As Integer lLastRow = Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Range("E1") = lLastRow If lLastRow > 200 Then MsgBox "You are generating numbers for more than 200 rows!! Either increase the Array, or go to 'Plan B'" Exit Sub End If MinNumber = 1 MaxNumber = lLastRow / 6 Range("D1") = MaxNumber For i = 1 To lLastRow lRndNbr = Int((Rnd * (MaxNumber - MinNumber + 1)) + MinNumber) aLimitTo6(lRndNbr) = aLimitTo6(lRndNbr) + 1 If aLimitTo6(lRndNbr) > 6 Then Debug.Print lRndNbr & " already generated six times!!" Do ' Try forever? lRndNbr = Int((Rnd * (MaxNumber - MinNumber + 1)) + MinNumber) aLimitTo6(lRndNbr) = aLimitTo6(lRndNbr) + 1 If aLimitTo6(lRndNbr) > 6 Then Debug.Print "Tried once to get another random number (" & lRndNbr & "), but failed!! What do you want to do?" Else Cells(i, 1).value = lRndNbr Exit Do End If Loop Else Cells(i, 1).value = lRndNbr End If Next i End Sub