Jump to content

Formula para gerar números aleatórios gera números repetidos


Recommended Posts

Olá, baixei recentemente uma fórmula para gerar números aleatórios no vba para Lotomania mas a mesma gera combinações repetidas.

Alguém saberia me dizer qual o problema da fórmula.

Abaixo a fórmula.

 

Sub test()

Dim Numjogos         As Long
Dim NumDezenas       As Integer

Numjogos = 1048576 'Número jogos
NumDezenas = 50 'N dezenas

Dim Li As Long
Li = 1 ' Na linha 1
For i = 1 To Numjogos
 
Jogo_Time Li, NumDezenas
Li = Li + 1
Next i


Sheets(1).Select

End Sub

Sub Jogo_Time(Linha, qtde)

'Randomize Timer
a = qtde 'quantidade de dezenas
c = 100    'limite de 1 a 100 de dezenas
s = 1 'Na coluna 1

For i = 0 To 99
'Valores ou variaveis do tipo Sigle são armazenadas como números IEEE de vírgula flutuante de 32 bits (4 bytes)
'São números com casas decimais ou fracionados  Ex: 0,25333
'Função "Rnd" Retorna um Single que contém um número aleatório podendo ser positivo ou negativo .

If Rnd <= a / c Then
a = a - 1
Cells(Linha, s) = i
s = s + 1
End If
c = c - 1
Next i


End Sub
Sub tes()

 

Agradeço qualquer ajuda.

Link to comment
Share on other sites

ola zangado( brabo) esta macro alem de gerar aleatorio, gera 5 por linha e 5 por coluna que é que esta ocoreendo em 92%

Private Function Comb(r As Long, n As Long)
  Dim c1 As New Collection, c2 As New Collection, arr(), arrTemp(), i As Long, j As Long, v
  For i = 1 To n
    c1.Add Array(-1, i)
  Next i
  While c1.Count
    arr = c1(1)
    c1.Remove 1
    j = UBound(arr)
    If j = r Then
      c2.Add arr
    Else
      ReDim Preserve arr(j + 1)
      For i = arr(j) + 1 To n
        arr(j + 1) = i
        c1.Add arr
      Next i
    End If
  Wend
  ReDim arr(1 To c2.Count)
  ReDim arrTemp(1 To r)
  i = 0
  For Each v In c2
    i = i + 1
    For j = 1 To r
      arrTemp(j) = v(j)
    Next j
    arr(i) = arrTemp
  Next v
  Comb = arr
End Function

Sub Main()
  Dim rng As Range, arrTemp(), arr(), arr1(), arr2(), arrComb(1 To 4), isFound As Boolean, v
  Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i As Long, j As Long, k As Long

  For i = 1 To 4
    arrComb(i) = Comb(i, 5)
  Next i

  Sheets("Plan2").Select
  Set rng = Range("A1").CurrentRegion
  Rows("12:23").ClearContents
  rng.Interior.ColorIndex = 2
  arr = rng.Value
  ReDim arrTemp(1 To 5)

loop1:
  arr1 = arr
  For i = 1 To 5
    arrTemp(1) = 1: arrTemp(2) = 1: arrTemp(3) = Int(Rnd * 2): arrTemp(4) = 0: arrTemp(5) = 0
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    If k = 0 Or k = 5 Then GoTo loop1
  Next j
  arr = arr1

loop2:
  arr1 = arr
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i, j))
    Next j
    For j = 1 To k
      arrTemp(j) = 0
    Next j
    For j = k + 1 To 5
      arrTemp(j) = 1
    Next j
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j + 5) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j + 5))
    Next i
    If k = 0 Or k = 5 Then GoTo loop2
  Next j
  arr = arr1
  
loop3:
  arr1 = arr
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    For i = 1 To k
      arrTemp(i) = 0
    Next i
    For i = k + 1 To 5
      arrTemp(i) = 1
    Next i
    For i = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(i)
      arrTemp(i) = arrTemp(k)
      arrTemp(k) = v
    Next i
    For i = 1 To 5
      arr1(i + 5, j) = IIf(arrTemp(i) = 1, 1, vbNullString)
    Next i
  Next j
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    If k = 0 Or k = 5 Then GoTo loop3
  Next i
  arr = arr1
  
loop4:
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    arrTemp(i) = arrComb(5 - k)
  Next i
  For i1 = 1 To UBound(arrTemp(1))
    For j = 1 To 5
      arr1(6, j + 5) = vbNullString
    Next j
    For j = 1 To UBound(arrTemp(1)(i1))
      arr1(6, 5 + arrTemp(1)(i1)(j)) = 1
    Next j
    For i2 = 1 To UBound(arrTemp(2))
      For j = 1 To 5
        arr1(7, j + 5) = vbNullString
      Next j
      For j = 1 To UBound(arrTemp(2)(i2))
        arr1(7, 5 + arrTemp(2)(i2)(j)) = 1
      Next j
      For i3 = 1 To UBound(arrTemp(3))
        For j = 1 To 5
          arr1(8, j + 5) = vbNullString
        Next j
        For j = 1 To UBound(arrTemp(3)(i3))
          arr1(8, 5 + arrTemp(3)(i3)(j)) = 1
        Next j
        For i4 = 1 To UBound(arrTemp(4))
          For j = 1 To 5
            arr1(9, j + 5) = vbNullString
          Next j
          For j = 1 To UBound(arrTemp(4)(i4))
            arr1(9, 5 + arrTemp(4)(i4)(j)) = 1
          Next j
          For i5 = 1 To UBound(arrTemp(5))
            For j = 1 To 5
              arr1(10, j + 5) = vbNullString
            Next j
            For j = 1 To UBound(arrTemp(5)(i5))
              arr1(10, 5 + arrTemp(5)(i5)(j)) = 1
            Next j
           '=================
            isFound = True
             For j = 1 To 5
               k = 0
              For i = 1 To 10
                k = k + Val(arr1(i, j + 5))
              Next i
              If k <> 5 Then
                 isFound = False
                 Exit For
              End If
            Next j
            If isFound Then
               arr = rng.Value
               For i = 1 To UBound(arr, 1)
                 For j = 1 To UBound(arr, 2)
                   If arr1(i, j) = vbNullString Then arr(i, j) = vbNullString
                 Next j
               Next i
               Range("A12").Resize(UBound(arr1, 1), UBound(arr, 2)).Value = arr
               ReDim arrTemp(1 To 1, 1 To 101)
               k = 0
               For i = 1 To 5
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 1 To 5
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               k = k + 1
               arrTemp(1, k) = "Total " & k - 1 & " numbers."
               Range("A23").Resize(1, k) = arrTemp
               Exit Sub
            End If
           '=================
          Next i5
        Next i4
      Next i3
    Next i2
  Next i1
End Sub
Sub Generate300()
  Dim i As Long
  With Sheets("Plan3")
    .Cells.ClearContents
    For i = 1 To 300
      Main
      Sheets("Plan2").Range("A23").CurrentRegion.Copy .Range("A65000").End(xlUp).Offset(1)
      MsgBox "Iteration : " & i
    Next i
  End With
End Sub
Link to comment
Share on other sites

22 horas atrás, sorel disse:

ola zangado( brabo) esta macro alem de gerar aleatorio, gera 5 por linha e 5 por coluna que é que esta ocoreendo em 92%


Private Function Comb(r As Long, n As Long)
  Dim c1 As New Collection, c2 As New Collection, arr(), arrTemp(), i As Long, j As Long, v
  For i = 1 To n
    c1.Add Array(-1, i)
  Next i
  While c1.Count
    arr = c1(1)
    c1.Remove 1
    j = UBound(arr)
    If j = r Then
      c2.Add arr
    Else
      ReDim Preserve arr(j + 1)
      For i = arr(j) + 1 To n
        arr(j + 1) = i
        c1.Add arr
      Next i
    End If
  Wend
  ReDim arr(1 To c2.Count)
  ReDim arrTemp(1 To r)
  i = 0
  For Each v In c2
    i = i + 1
    For j = 1 To r
      arrTemp(j) = v(j)
    Next j
    arr(i) = arrTemp
  Next v
  Comb = arr
End Function

Sub Main()
  Dim rng As Range, arrTemp(), arr(), arr1(), arr2(), arrComb(1 To 4), isFound As Boolean, v
  Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i As Long, j As Long, k As Long

  For i = 1 To 4
    arrComb(i) = Comb(i, 5)
  Next i

  Sheets("Plan2").Select
  Set rng = Range("A1").CurrentRegion
  Rows("12:23").ClearContents
  rng.Interior.ColorIndex = 2
  arr = rng.Value
  ReDim arrTemp(1 To 5)

loop1:
  arr1 = arr
  For i = 1 To 5
    arrTemp(1) = 1: arrTemp(2) = 1: arrTemp(3) = Int(Rnd * 2): arrTemp(4) = 0: arrTemp(5) = 0
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    If k = 0 Or k = 5 Then GoTo loop1
  Next j
  arr = arr1

loop2:
  arr1 = arr
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i, j))
    Next j
    For j = 1 To k
      arrTemp(j) = 0
    Next j
    For j = k + 1 To 5
      arrTemp(j) = 1
    Next j
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j + 5) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j + 5))
    Next i
    If k = 0 Or k = 5 Then GoTo loop2
  Next j
  arr = arr1
  
loop3:
  arr1 = arr
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    For i = 1 To k
      arrTemp(i) = 0
    Next i
    For i = k + 1 To 5
      arrTemp(i) = 1
    Next i
    For i = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(i)
      arrTemp(i) = arrTemp(k)
      arrTemp(k) = v
    Next i
    For i = 1 To 5
      arr1(i + 5, j) = IIf(arrTemp(i) = 1, 1, vbNullString)
    Next i
  Next j
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    If k = 0 Or k = 5 Then GoTo loop3
  Next i
  arr = arr1
  
loop4:
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    arrTemp(i) = arrComb(5 - k)
  Next i
  For i1 = 1 To UBound(arrTemp(1))
    For j = 1 To 5
      arr1(6, j + 5) = vbNullString
    Next j
    For j = 1 To UBound(arrTemp(1)(i1))
      arr1(6, 5 + arrTemp(1)(i1)(j)) = 1
    Next j
    For i2 = 1 To UBound(arrTemp(2))
      For j = 1 To 5
        arr1(7, j + 5) = vbNullString
      Next j
      For j = 1 To UBound(arrTemp(2)(i2))
        arr1(7, 5 + arrTemp(2)(i2)(j)) = 1
      Next j
      For i3 = 1 To UBound(arrTemp(3))
        For j = 1 To 5
          arr1(8, j + 5) = vbNullString
        Next j
        For j = 1 To UBound(arrTemp(3)(i3))
          arr1(8, 5 + arrTemp(3)(i3)(j)) = 1
        Next j
        For i4 = 1 To UBound(arrTemp(4))
          For j = 1 To 5
            arr1(9, j + 5) = vbNullString
          Next j
          For j = 1 To UBound(arrTemp(4)(i4))
            arr1(9, 5 + arrTemp(4)(i4)(j)) = 1
          Next j
          For i5 = 1 To UBound(arrTemp(5))
            For j = 1 To 5
              arr1(10, j + 5) = vbNullString
            Next j
            For j = 1 To UBound(arrTemp(5)(i5))
              arr1(10, 5 + arrTemp(5)(i5)(j)) = 1
            Next j
           '=================
            isFound = True
             For j = 1 To 5
               k = 0
              For i = 1 To 10
                k = k + Val(arr1(i, j + 5))
              Next i
              If k <> 5 Then
                 isFound = False
                 Exit For
              End If
            Next j
            If isFound Then
               arr = rng.Value
               For i = 1 To UBound(arr, 1)
                 For j = 1 To UBound(arr, 2)
                   If arr1(i, j) = vbNullString Then arr(i, j) = vbNullString
                 Next j
               Next i
               Range("A12").Resize(UBound(arr1, 1), UBound(arr, 2)).Value = arr
               ReDim arrTemp(1 To 1, 1 To 101)
               k = 0
               For i = 1 To 5
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 1 To 5
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               k = k + 1
               arrTemp(1, k) = "Total " & k - 1 & " numbers."
               Range("A23").Resize(1, k) = arrTemp
               Exit Sub
            End If
           '=================
          Next i5
        Next i4
      Next i3
    Next i2
  Next i1
End Sub
Sub Generate300()
  Dim i As Long
  With Sheets("Plan3")
    .Cells.ClearContents
    For i = 1 To 300
      Main
      Sheets("Plan2").Range("A23").CurrentRegion.Copy .Range("A65000").End(xlUp).Offset(1)
      MsgBox "Iteration : " & i
    Next i
  End With
End Sub

Olá Sorel rodei sua macro mas ela está dando erro, escrevi onde está o erro, espero que o corrija.

 

Private Function Comb(r As Long, n As Long)
  Dim c1 As New Collection, c2 As New Collection, arr(), arrTemp(), i As Long, j As Long, v
  For i = 1 To n
    c1.Add Array(-1, i)
  Next i
  While c1.Count
    arr = c1(1)
    c1.Remove 1
    j = UBound(arr)
    If j = r Then
      c2.Add arr
    Else
      ReDim Preserve arr(j + 1)
      For i = arr(j) + 1 To n
        arr(j + 1) = i
        c1.Add arr
      Next i
    End If
  Wend
  ReDim arr(1 To c2.Count)
  ReDim arrTemp(1 To r)
  i = 0
  For Each v In c2
    i = i + 1
    For j = 1 To r
      arrTemp(j) = v(j)
    Next j
    arr(i) = arrTemp
  Next v
  Comb = arr
End Function

Sub Main()
  Dim rng As Range, arrTemp(), arr(), arr1(), arr2(), arrComb(1 To 4), isFound As Boolean, v
  Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i As Long, j As Long, k As Long

  For i = 1 To 4
    arrComb(i) = Comb(i, 5)
  Next i

  Sheets("Plan2").Select
  Set rng = Range("A1").CurrentRegion
  Rows("12:23").ClearContents
  rng.Interior.ColorIndex = 2
  arr = rng.Value                                                                          '>ERRO EM TEMPO DE EXECUÇÃO 13
  ReDim arrTemp(1 To 5)

loop1:
  arr1 = arr
  For i = 1 To 5
    arrTemp(1) = 1: arrTemp(2) = 1: arrTemp(3) = Int(Rnd * 2): arrTemp(4) = 0: arrTemp(5) = 0
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    If k = 0 Or k = 5 Then GoTo loop1
  Next j
  arr = arr1

loop2:
  arr1 = arr
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i, j))
    Next j
    For j = 1 To k
      arrTemp(j) = 0
    Next j
    For j = k + 1 To 5
      arrTemp(j) = 1
    Next j
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j + 5) = IIf(arrTemp(j) = 1, 1, vbNullString)
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j + 5))
    Next i
    If k = 0 Or k = 5 Then GoTo loop2
  Next j
  arr = arr1
  
loop3:
  arr1 = arr
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))
    Next i
    For i = 1 To k
      arrTemp(i) = 0
    Next i
    For i = k + 1 To 5
      arrTemp(i) = 1
    Next i
    For i = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(i)
      arrTemp(i) = arrTemp(k)
      arrTemp(k) = v
    Next i
    For i = 1 To 5
      arr1(i + 5, j) = IIf(arrTemp(i) = 1, 1, vbNullString)
    Next i
  Next j
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    If k = 0 Or k = 5 Then GoTo loop3
  Next i
  arr = arr1
  
loop4:
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))
    Next j
    arrTemp(i) = arrComb(5 - k)
  Next i
  For i1 = 1 To UBound(arrTemp(1))
    For j = 1 To 5
      arr1(6, j + 5) = vbNullString
    Next j
    For j = 1 To UBound(arrTemp(1)(i1))
      arr1(6, 5 + arrTemp(1)(i1)(j)) = 1
    Next j
    For i2 = 1 To UBound(arrTemp(2))
      For j = 1 To 5
        arr1(7, j + 5) = vbNullString
      Next j
      For j = 1 To UBound(arrTemp(2)(i2))
        arr1(7, 5 + arrTemp(2)(i2)(j)) = 1
      Next j
      For i3 = 1 To UBound(arrTemp(3))
        For j = 1 To 5
          arr1(8, j + 5) = vbNullString
        Next j
        For j = 1 To UBound(arrTemp(3)(i3))
          arr1(8, 5 + arrTemp(3)(i3)(j)) = 1
        Next j
        For i4 = 1 To UBound(arrTemp(4))
          For j = 1 To 5
            arr1(9, j + 5) = vbNullString
          Next j
          For j = 1 To UBound(arrTemp(4)(i4))
            arr1(9, 5 + arrTemp(4)(i4)(j)) = 1
          Next j
          For i5 = 1 To UBound(arrTemp(5))
            For j = 1 To 5
              arr1(10, j + 5) = vbNullString
            Next j
            For j = 1 To UBound(arrTemp(5)(i5))
              arr1(10, 5 + arrTemp(5)(i5)(j)) = 1
            Next j
           '=================
            isFound = True
             For j = 1 To 5
               k = 0
              For i = 1 To 10
                k = k + Val(arr1(i, j + 5))
              Next i
              If k <> 5 Then
                 isFound = False
                 Exit For
              End If
            Next j
            If isFound Then
               arr = rng.Value
               For i = 1 To UBound(arr, 1)
                 For j = 1 To UBound(arr, 2)
                   If arr1(i, j) = vbNullString Then arr(i, j) = vbNullString
                 Next j
               Next i
               Range("A12").Resize(UBound(arr1, 1), UBound(arr, 2)).Value = arr
               ReDim arrTemp(1 To 1, 1 To 101)
               k = 0
               For i = 1 To 5
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 1 To 5
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               k = k + 1
               arrTemp(1, k) = "Total " & k - 1 & " numbers."
               Range("A23").Resize(1, k) = arrTemp
               Exit Sub
            End If
           '=================
          Next i5
        Next i4
      Next i3
    Next i2
  Next i1
End Sub
Sub Generate300()
  Dim i As Long
  With Sheets("Plan3")
    .Cells.ClearContents
    For i = 1 To 300
      Main
      Sheets("Plan2").Range("A23").CurrentRegion.Copy .Range("A65000").End(xlUp).Offset(1)
      MsgBox "Iteration : " & i
    Next i
  End With
End Sub
 

Link to comment
Share on other sites

Guest Zangado

@sorel 

isso não é uma formula , é uma macro

 

não sorel , não funciona somente em ingles

funcioa com os dados da planilha especifica 

e vc acha que todos tem que estar disposto 100% em 100% das vezes que vc ´pede algo né

as pessoas ajudam onde podem , quando podem e  naquilo que acham que a ajuda é necessária 

 

e se foi feito em cima de excel em ingles já foi adaptado no em português pq 

Sheets("Plan2").Range("A23")

Plan é o nome padrão das abas no excel em pt e não em ingles

>>Planilha 

em ingles seria 

Worksheets("Sheet2")

 

Link to comment
Share on other sites

Esta planilha esta com tantos erros que acho difícil de arruma-lá, mas se uma alma caridosa se dispuser ficaria grato.

Abaixo a planilha com os erros que achei.

 

Private Function Comb(r As Long, n As Long)
  Dim c1 As New Collection, c2 As New Collection, arr(), arrTemp(), i As Long, j As Long, v
  For i = 1 To n
    c1.Add Array(-1, i)
  Next i
  While c1.Count
    arr = c1(1)
    c1.Remove 1
    j = UBound(arr)
    If j = r Then
      c2.Add arr
    Else
      ReDim Preserve arr(j + 1)
      For i = arr(j) + 1 To n
        arr(j + 1) = i
        c1.Add arr
      Next i
    End If
  Wend
  ReDim arr(1 To c2.Count)
  ReDim arrTemp(1 To r)
  i = 0
  For Each v In c2
    i = i + 1
    For j = 1 To r
      arrTemp(j) = v(j)
    Next j
    arr(i) = arrTemp
  Next v
  Comb = arr
End Function

Sub Main()
  Dim rng As Range, arrTemp(), arr(), arr1(), arr2(), arrComb(1 To 4), isFound As Boolean, v
  Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i As Long, j As Long, k As Long

  For i = 1 To 4
    arrComb(i) = Comb(i, 5)
  Next i

  Sheets("Plan2").Select
  Set rng = Range("A1").CurrentRegion
  Rows("12:23").ClearContents
  rng.Interior.ColorIndex = 2
  arr = rng.Value                             'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
  ReDim arrTemp(1 To 5)

loop1:
  arr1 = arr
  For i = 1 To 5
    arrTemp(1) = 1: arrTemp(2) = 1: arrTemp(3) = Int(Rnd * 2): arrTemp(4) = 0: arrTemp(5) = 0
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j) = IIf(arrTemp(j) = 1, 1, vbNullString)             'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))                                       'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next i
    If k = 0 Or k = 5 Then GoTo loop1
  Next j
  arr = arr1

loop2:
  arr1 = arr
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i, j))                            'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j
    For j = 1 To k
      arrTemp(j) = 0
    Next j
    For j = k + 1 To 5
      arrTemp(j) = 1
    Next j
    For j = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(j)
      arrTemp(j) = arrTemp(k)
      arrTemp(k) = v
    Next j
    For j = 1 To 5
      arr1(i, j + 5) = IIf(arrTemp(j) = 1, 1, vbNullString)               'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j
  Next i
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j + 5))                                          'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next i
    If k = 0 Or k = 5 Then GoTo loop2
  Next j
  arr = arr1
  
loop3:
  arr1 = arr
  For j = 1 To 5
    k = 0
    For i = 1 To 5
      k = k + Val(arr1(i, j))                                           'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next i
    For i = 1 To k
      arrTemp(i) = 0
    Next i
    For i = k + 1 To 5
      arrTemp(i) = 1
    Next i
    For i = 1 To 5
      k = Int(Rnd * 5) + 1
      v = arrTemp(i)
      arrTemp(i) = arrTemp(k)
      arrTemp(k) = v
    Next i
    For i = 1 To 5
      arr1(i + 5, j) = IIf(arrTemp(i) = 1, 1, vbNullString)              'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next i
  Next j
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))                                         'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j
    If k = 0 Or k = 5 Then GoTo loop3
  Next i
  arr = arr1
  
loop4:
  For i = 1 To 5
    k = 0
    For j = 1 To 5
      k = k + Val(arr1(i + 5, j))                                    'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j
    arrTemp(i) = arrComb(5 - k)                                      'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
  Next i
  For i1 = 1 To UBound(arrTemp(1))                                   'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
    For j = 1 To 5
      arr1(6, j + 5) = vbNullString                                  'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j
    For j = 1 To UBound(arrTemp(1)(i1))                               'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
      arr1(6, 5 + arrTemp(1)(i1)(j)) = 1                              'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
    Next j
    For i2 = 1 To UBound(arrTemp(2))                                 'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
      For j = 1 To 5
        arr1(7, j + 5) = vbNullString                                'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
      Next j
      For j = 1 To UBound(arrTemp(2)(i2))                             'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
        arr1(7, 5 + arrTemp(2)(i2)(j)) = 1                            'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
      Next j
      For i3 = 1 To UBound(arrTemp(3))                                'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
        For j = 1 To 5
          arr1(8, j + 5) = vbNullString                               'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
        Next j
        For j = 1 To UBound(arrTemp(3)(i3))                            'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
          arr1(8, 5 + arrTemp(3)(i3)(j)) = 1                           'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
        Next j
        For i4 = 1 To UBound(arrTemp(4))                              'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
          For j = 1 To 5
            arr1(9, j + 5) = vbNullString                             'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
          Next j
          For j = 1 To UBound(arrTemp(4)(i4))                        'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
            arr1(9, 5 + arrTemp(4)(i4)(j)) = 1                       'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
          Next j
          For i5 = 1 To UBound(arrTemp(5))                           'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
            For j = 1 To 5
              arr1(10, j + 5) = vbNullString                         'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
            Next j
            For j = 1 To UBound(arrTemp(5)(i5))                     'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
              arr1(10, 5 + arrTemp(5)(i5)(j)) = 1                   'ERRO DE TEMPO DE EXECUÇÃO 13 TIPOS INCOMPATIVEIS
            Next j
           '=================
            isFound = True
             For j = 1 To 5
               k = 0
              For i = 1 To 10
                k = k + Val(arr1(i, j + 5))                        'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
              Next i
              If k <> 5 Then
                 isFound = False
                 Exit For
              End If
            Next j
            If isFound Then
               arr = rng.Value
               For i = 1 To UBound(arr, 1)
                 For j = 1 To UBound(arr, 2)
                   If arr1(i, j) = vbNullString Then arr(i, j) = vbNullString
                 Next j
               Next i
               Range("A12").Resize(UBound(arr1, 1), UBound(arr, 2)).Value = arr
               ReDim arrTemp(1 To 1, 1 To 101)
               k = 0
               For i = 1 To 5
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 1 To 5
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 1 To 5
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               For i = 6 To 10
                 For j = 6 To 10
                   If arr(i, j) <> vbNullString Then
                      k = k + 1
                      arrTemp(1, k) = arr(i, j)
                   End If
                 Next j
               Next i
               k = k + 1
               arrTemp(1, k) = "Total " & k - 1 & " numbers."
               Range("A23").Resize(1, k) = arrTemp
               Exit Sub
            End If
           '=================
          Next i5
        Next i4
      Next i3
    Next i2
  Next i1
End Sub
Sub Generate300()
  Dim i As Long
  With Sheets("Plan3")
    .Cells.ClearContents
    For i = 1 To 300
      Main
      Sheets("Plan2").Range("A23").CurrentRegion.Copy .Range("A65000").End(xlUp).Offset(1)
      MsgBox "Iteration : " & i
    Next i
  End With
End Sub
 

Link to comment
Share on other sites

será que passou de portugues para ingles! mas tabem quando conseguir ajeitar vai valer um milhao,

acho que para excel 2010 ou superior, ela filtra 5 por linha e 5 colunas no  maximo, talvez tenha outro forma de gerar pelo c++ até hoje ninguem conseguiu fazer este filtro

Link to comment
Share on other sites

Guest Zangado

@Fábio da Silva @sorel 

como falei se é para sortear jogos aleatórios tem a que postei

gera quantas linhas quiser

gera quantas colunas de dezenas

não repete

pode se escolher prioridade de dezenas 

tem como definir limite de dezena

pode escolher as dezenas que vão ser sorteadas

 

até mostrarem o diferencial de algo que sorteia aleatorio para que montar outra ou ficar fuçando em uma macros desse tamanho que  sequer se tem os tipo de dados e range que se tem na planilha de trabalho

 

 Set rng = Range("A1").CurrentRegion

pode ter qualquer tamanho  qualquer quantidade de linhas ou de colunas, não ficando claro com oq a macros trabalha


  Rows("12:23").ClearContents
  rng.Interior.ColorIndex = 2

pinta a range
  arr = rng.Value           

pega valor da range

loop1:
  arr1 = arr

copia os valores para arr1

  For j = 1 To 5
      arr1(i, j) = IIf(arrTemp(j) = 1, 1, vbNullString)           
    Next j

ao que parece j de arr1 tem 5 elementos 

 

For j = 1 To 5
      arr1(i, j + 5) = IIf(arrTemp(j) = 1, 1, vbNullString)               'ERRO DE EXECUÇÃO 9 SUBSCRITO FORA DO INTERVALO
    Next j

se j de arr1 só tem 5 elementos pq aqui usa j que já vai de 1 até 5  (+5) ????

 

tem que se ter um motivo muito bom para se pegar isso para consertar e definir sua funcionalidade 

Link to comment
Share on other sites

  • 3 months later...

@Zangado

Pode me auxiliar em uma função VBA?

.

Na coluna T terei valores em ordem crescente colados, quero que o comando encontre o MAIOR VALOR =(MÁXIMO) e selecione a célula abaixo dele.

.

Digamos que o maior valor que está na coluna esteja na T802 e a função deve selecionar a T803, e assim por diante quando for colocado maiores valores na coluna.

.

Tentei essa função, mas, pelo fato do conteúdo ser copiado de outro campo para ser armazenado no outro ele não reconhece a última vazia de baixo para cima devido ao valor falso ;"") da formula, usando ''colar especial valores''.

Range("T6000").End(xlUp).Offset(1, 0).Select

.

Grato desde já!

Link to comment
Share on other sites

Guest Zangado

@Edu-Aacaracas 

nem entendi direito, mas vc tem que fazer um loop nos valores acho que no seu caso da linha inicial ate a final para definir o maior valor e armazenar em 2 variaveis uma para o valor e outra para a linha que se encontra o valor 

e no final do processo ir para a linha armazenada 

algo como  

 

for linhaAtual= 2 to linhafinal

  if valorA > valorB them 

      valorB=valorA

      L=linhaAtual

  end if

next

cells( L , C ).Select

 

para saber o maior valor de um conjunto tem que comparar todo o conjunto

 

 

Link to comment
Share on other sites

@Zangado

É apenas localizar o maior valor na coluna e selecionar a celula posterior ao maior valor na coluna , com a célula abaixo do maior valor eu irei colar o conteúdo.

.

Os valores estão em ordem crescente da T4:T em diante

Célula da coluna T800 está o valor 699

Célula da coluna T801 está vazia

Célula da coluna T802 está o valor 701 < que é o maior valor cadastrado na coluna até o momento.

.

Basta que o comando deixe a célula T803 selecionada (Ativada) para receber o colar especial

.

Seria algo simples como essa função que seleciona a última célula vazia de baixo para cima na coluna

Range("T6000").End(xlUp).Offset(1, 0).Select

Link to comment
Share on other sites

Guest Zangado
1 hora atrás, Edu-Aacaracas disse:

quero que o comando encontre o MAIOR VALOR =(MÁXIMO) e selecione a célula abaixo dele.

bem eu descrevi esse processo 

 

mas se é para ir para a ultima linha seria algo assim

coluna="T"

ultimalinha = Cells(Rows.COUNT, coluna).End(xlUp).Row + 1

cells( ultimalinha , coluna).Select

 

existem varias maneiras eu particularmente uso essa 

Link to comment
Share on other sites

Guest Zangado
9 horas atrás, Pedepano disse:

Edu-Aacaracas me perdoe me entrometer no assunto, já que o pedido foi redirecionado para o @Zangado

mais espero que possa lhe ajuda de alguma forma, pelo que entendi..

fique a vontade, mesmo pq não entendi direito oq  ele quer

para mim parece mais buscar a ultima linha já que se as dezenas já estão organizadas o maior valor já está situado na ultima posição 

se ele quer outra coluna onde se tem o valro é somente pegar a ultima linha e selecionar outra coluna 

 

coluna="T"

ultimalinha = Cells(Rows.COUNT, coluna).End(xlUp).Row + 1

coluna="B"  ' troca a coluna de referencia 

cells( ultimalinha , coluna).Select

 

poderia ser até de outra aba

ultimalinha = Sheets("aba2").Cells(Rows.COUNT, coluna).End(xlUp).Row + 1

Link to comment
Share on other sites

@Zangado Valeu pela disposição e gentileza!! Devido ela ser colado a partir de outro campo extraído com formulas o "" atrapalhava a localização da última célula preenchida de baixo para cima.

.

@Pedepano Funcionou perfeitamente, agora ele está colando no local certo ( antes ele pulava várias linhas para baixo para colar o conteúdo por conta do ("").

Muito obrigado ae pela disposição e gentileza!

.

Ficou assim aqui.

Sub BUSCAR()
'
' copiar Macro
'

'
    Range("R5:AJ29").Select
    Selection.Copy
    Sheets("RESULTADOS").Select
    Range("U1") = "=max(T4:T10000)"
    r = Range("U1")
    Range("T4:T10000").Select
    Selection.Find(What:=r, After:=ActiveCell, LookIn:=xlValues, _
    LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
    MatchCase:=False, SearchFormat:=False).Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Sheets("Extração").Select
    Range("AJ2").Select

    End Sub

Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Reply to this topic...

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • Recently Browsing   0 members

    • No registered users viewing this page.
×
×
  • Create New...