Notifications
Clear all

Criar números aleatórios, sem repetição em ordem crescente.

4 Posts
2 Usuários
0 Reactions
1,613 Visualizações
(@cristy0505)
Posts: 28
Eminent Member
Topic starter
 

Bom dia, tenho a seguinte macro:

Sub Sortear()
    Dim V() 'Vetor
    Dim CONT As Integer 'Contador
    Dim I As Integer 'Índice do vetor
    Dim QUANT_SORT As Integer 'Recebe o valor de quantos Nº aleatórios serão gerados
    Dim NUM_SORT As Integer 'Recebe um número sorteado
    Dim LIN As Integer 'Determina em que linha o Nº aleatório será colocado
    Dim REP As Integer 'Repetidor
    Dim VAL_MIN As Integer 'Recebe o valor mínimo na faixa de números
    Dim VAL_MAX As Integer 'Recebe o Valor máximo na faixa de números
    Dim FAIXA_SORT As Integer 'Faixa de valores possíveis ao sorteio
   
ActiveSheet.Name = "Sorteio"
On Error GoTo SAIDA
[E6:E65536].ClearContents
Range("E6:E65536").Font.Bold = True
Range("E6:E65536").Font.Size = 10
INICIO:

    VAL_MIN = InputBox("Qual será o MENOR número possível nesse sorteio?")
    VAL_MAX = InputBox("Qual será o MAIOR número possível desse sorteio?")
   
CHECA_VALOR_MAX:
   
    If VAL_MAX <= VAL_MIN Then
       If MsgBox("Você deve digitar um número MAIOR para o valor máximo ou alterar o valor mínimo. O Valor mínimo atual é " & VAL_MIN & ". Deseja Alterará-lo?", vbQuestion + vbYesNo + vbApplicationModal + vbDefaultButton1) = vbYes Then
           VAL_MIN = InputBox("Corrija o valor mínimo para o sorteio.")
              If VAL_MAX <= VAL_MIN Then
                GoTo CHECA_VALOR_MAX
              End If
       Else
           VAL_MAX = InputBox("Nesse caso digite um valor MAIOR que " & VAL_MIN & ". O valor máximo atual é " & VAL_MAX & ".")
              If VAL_MAX <= VAL_MIN Then
                GoTo CHECA_VALOR_MAX
              End If
       End If
    End If
                
FAIXA_SORT = VAL_MAX - VAL_MIN + 1
     
    QUANT_SORT = InputBox("Quantos números você deseja sortear?")
   
CHECA_FAIXA:
   
       If QUANT_SORT > FAIXA_SORT Then
          QUANT_SORT = InputBox("A quantidade de sorteios supera o valor máximo de números possíveis a serem sorteados sem repetições. Por favor corrija para um número MENOR ou IGUAl a " & FAIXA_SORT & ".")
          GoTo CHECA_FAIXA
       End If
      
       If VAL_MAX = VAL_MIN + 1 Then
            If MsgBox("Você determinou uma faixa muito estreita para a realização de um sorteio. Deseja Alterar os dados?", vbExclamation + vbYesNo + vbApplicationModal + vbDefaultButton1) = vbYes Then
                GoTo INICIO
            Else
                MsgBox "Não é possível realizar um sorteio com os números dados.", vbOKOnly + vbApplicationModal + vbCritical
                GoTo SAIDA
            End If
       End If
      
    Randomize
    For LIN = 1 To QUANT_SORT
        I = I + 1
        ReDim Preserve V(I)
REPETE:
        NUM_SORT = Int(rnd * VAL_MAX + VAL_MIN)
        REP = 0
        For CONT = I - LIN To I
            If NUM_SORT = V(CONT) Or NUM_SORT > VAL_MAX Then
                REP = 1
            End If
        Next
        If REP = 1 Then
            GoTo REPETE
        Else
            V(I) = NUM_SORT
        End If
    Next
    I = 0
    For LIN = 6 To QUANT_SORT
        I = I + 1
        Cells(LIN, 5) = V(I)
    Next LIN
SAIDA:

 ActiveWorkbook.Worksheets("Sorteio").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sorteio").Sort.SortFields.Add Key:=Range( _
        "E6:E55"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sorteio").Sort
        .SetRange Range("E6:E56")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

Ele está funcionando normal, porém está sorteando 5 números a menos (o número de linhas que usei para criar o cabeçalho, borda, etc.) do que o usuário especifica.

Gostaria que alguém me ajudasse a encontrar aonde está o erro, se possível...

Muito obrigada pela atenção.

 
Postado : 24/08/2012 7:38 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Altere o trecho
de:

    Next
    I = 0
    For LIN = 6 To QUANT_SORT
        I = I + 1
        Cells(LIN, 5) = V(I)
    Next LIN

Para:

    Next
        I = 0
        LIN = 6
        For I = 1 To QUANT_SORT
            Cells(LIN, 5) = V(I)
        LIN = LIN + 1
        Next

ou:

    Next
    I = 0
    For LIN = 6 To QUANT_SORT+5
        I = I + 1
        Cells(LIN, 5) = V(I)
    Next LIN
 
Postado : 24/08/2012 8:05 am
(@cristy0505)
Posts: 28
Eminent Member
Topic starter
 

Oi, Reinaldo, muito obrigada, funcionou certinho.

Caso alguém se interesse, está aqui o script totalmente funcional (graças ao Reinaldo):

Sortear números aleatórios em ordem crescente, sem repetição no excel (VBA)

Sub Sortear()
    Dim V() 'Vetor
    Dim CONT As Integer 'Contador
    Dim I As Integer 'Índice do vetor
    Dim QUANT_SORT As Integer 'Recebe o valor de quantos Nº aleatórios serão gerados
    Dim NUM_SORT As Integer 'Recebe um número sorteado
    Dim LIN As Integer 'Determina em que linha o Nº aleatório será colocado
    Dim REP As Integer 'Repetidor
    Dim VAL_MIN As Integer 'Recebe o valor mínimo na faixa de números
    Dim VAL_MAX As Integer 'Recebe o Valor máximo na faixa de números
    Dim FAIXA_SORT As Integer 'Faixa de valores possíveis ao sorteio
   
ActiveSheet.Name = "Sorteio"
On Error GoTo SAIDA
[E6:E65536].ClearContents
Range("E6:E65536").Font.Bold = True
Range("E6:E65536").Font.Size = 10
INICIO:

    VAL_MIN = InputBox("Qual será o MENOR número possível nesse sorteio?")
    VAL_MAX = InputBox("Qual será o MAIOR número possível desse sorteio?")
   
CHECA_VALOR_MAX:
   
    If VAL_MAX <= VAL_MIN Then
       If MsgBox("Você deve digitar um número MAIOR para o valor máximo ou alterar o valor mínimo. O Valor mínimo atual é " & VAL_MIN & ". Deseja Alterará-lo?", vbQuestion + vbYesNo + vbApplicationModal + vbDefaultButton1) = vbYes Then
           VAL_MIN = InputBox("Corrija o valor mínimo para o sorteio.")
              If VAL_MAX <= VAL_MIN Then
                GoTo CHECA_VALOR_MAX
              End If
       Else
           VAL_MAX = InputBox("Nesse caso digite um valor MAIOR que " & VAL_MIN & ". O valor máximo atual é " & VAL_MAX & ".")
              If VAL_MAX <= VAL_MIN Then
                GoTo CHECA_VALOR_MAX
              End If
       End If
    End If
                
FAIXA_SORT = VAL_MAX - VAL_MIN + 1
     
    QUANT_SORT = InputBox("Quantos números você deseja sortear?")
   
CHECA_FAIXA:
   
       If QUANT_SORT > FAIXA_SORT Then
          QUANT_SORT = InputBox("A quantidade de sorteios supera o valor máximo de números possíveis a serem sorteados sem repetições. Por favor corrija para um número MENOR ou IGUAl a " & FAIXA_SORT & ".")
          GoTo CHECA_FAIXA
       End If
      
       If VAL_MAX = VAL_MIN + 1 Then
            If MsgBox("Você determinou uma faixa muito estreita para a realização de um sorteio. Deseja Alterar os dados?", vbExclamation + vbYesNo + vbApplicationModal + vbDefaultButton1) = vbYes Then
                GoTo INICIO
            Else
                MsgBox "Não é possível realizar um sorteio com os números dados.", vbOKOnly + vbApplicationModal + vbCritical
                GoTo SAIDA
            End If
       End If
      
    Randomize
    For LIN = 1 To QUANT_SORT
        I = I + 1
        ReDim Preserve V(I)
REPETE:
        NUM_SORT = Int(rnd * VAL_MAX + VAL_MIN)
        REP = 0
        For CONT = I - LIN To I
            If NUM_SORT = V(CONT) Or NUM_SORT > VAL_MAX Then
                REP = 1
            End If
        Next
        If REP = 1 Then
            GoTo REPETE
        Else
            V(I) = NUM_SORT
        End If
    Next
    I = 0
    For LIN = 6 To QUANT_SORT + 5
        I = I + 1
        Cells(LIN, 5) = V(I)
    Next LIN
SAIDA:

 ActiveWorkbook.Worksheets("Sorteio").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sorteio").Sort.SortFields.Add Key:=Range( _
        "E6:E55"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sorteio").Sort
        .SetRange Range("E6:E56")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub
 
Postado : 24/08/2012 8:19 am
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Bom dia!!

Lembre se de marcar sua postagem como resolvido na próxima vez!!!

Veja como em:
Marcar Tópico como Resolvido e Agradecimento
viewtopic.php?f=7&t=3784

Att ;)

 
Postado : 27/08/2012 5:23 am