Fábio da Silva Posted November 18, 2018 Share Posted November 18, 2018 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. Quote Link to comment Share on other sites More sharing options...
Guest Zangado Posted November 18, 2018 Share Posted November 18, 2018 @Fábio da Silva isso não é uma formula é uma macro pq não tenta essa planilha? Quote Link to comment Share on other sites More sharing options...
sorel Posted November 18, 2018 Share Posted November 18, 2018 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 Quote Link to comment Share on other sites More sharing options...
Fábio da Silva Posted November 19, 2018 Author Share Posted November 19, 2018 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 Quote Link to comment Share on other sites More sharing options...
sorel Posted November 20, 2018 Share Posted November 20, 2018 grande fabio,sim esta correto,esta formula nao foi eu foi um amigo de LONDRES( inglaterra0 aqui no brasil iriam cobrar pela formula claro, e ninguem conseguiria fazer ela so roda em ingles, nao vai ser facil corrigir, mas depois será de muita ajuda Quote Link to comment Share on other sites More sharing options...
Guest Zangado Posted November 20, 2018 Share Posted November 20, 2018 @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") Quote Link to comment Share on other sites More sharing options...
sorel Posted November 20, 2018 Share Posted November 20, 2018 ok , sim mas estou dando a planilia! ahh nao entendo( claro esta com erros) mas forum é para ajudara uns com outros, o ZANGADO tem como arrumar isto por favor! Quote Link to comment Share on other sites More sharing options...
Fábio da Silva Posted November 20, 2018 Author Share Posted November 20, 2018 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 Quote Link to comment Share on other sites More sharing options...
sorel Posted November 20, 2018 Share Posted November 20, 2018 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 Quote Link to comment Share on other sites More sharing options...
Guest Zangado Posted November 20, 2018 Share Posted November 20, 2018 @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 Quote Link to comment Share on other sites More sharing options...
Guest Posted February 21, 2019 Share Posted February 21, 2019 @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á! Quote Link to comment Share on other sites More sharing options...
Guest Zangado Posted February 21, 2019 Share Posted February 21, 2019 @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 Quote Link to comment Share on other sites More sharing options...
Guest Posted February 21, 2019 Share Posted February 21, 2019 @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 Quote Link to comment Share on other sites More sharing options...
Guest Zangado Posted February 21, 2019 Share Posted February 21, 2019 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 Quote Link to comment Share on other sites More sharing options...
Guest Zangado Posted February 22, 2019 Share Posted February 22, 2019 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 Quote Link to comment Share on other sites More sharing options...
Guest Posted February 22, 2019 Share Posted February 22, 2019 @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 Quote Link to comment Share on other sites More sharing options...
Recommended Posts
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.