Excel planilha vba jogos mega sena computador faz dez jogos aleatorios com interacoes

Qui, 25 de Novembro de 2010 06:44 Expedito Marcondes
Imprimir

Saberexcel - o site das macros

Essas Macros e Funções do Aplicativo Microsoft Excel VBA, produz uma dezena de jogos aleatórios da Mega-sena, usando interações aleatória no
em uma determinada célula. Abaixo as Funções Extenso usada neste exemplo foram inseridas com intuíto didático que poderá ajudar muitos em outras aplicações no Excel VBA.
Baixe o exemplo de planilha no fim da página.

Sub Teste()
'Range("D24").FormulaR1C1 = _
"=""Eu, seu computador farei, ""&Extenso(R[-23]C[5]) & "" Interações Aleatórias para 10 jogos."""
'Range("D25").Select
InsereNumerosAleatoriosSemDuplicados 60, Range("B1")
'Range("D24").FormulaR1C1 = _
' "=""Eu, seu computador fiz, ""&Extenso(R[-23]C[5]) & "" Interações Aleatórias para 10 jogos."""
'Range("D25").Select
End Sub

Sub InsereNumerosAleatoriosSemDuplicados(nValores As Integer, Cell As Range)
Dim Tabela As String, i As Integer, j As Integer
Tabela = ";"
Do While i < nValores
j = Int((nValores * Rnd) + 1)
If Not Tabela Like "*;" & j & ";*" Then
i = i + 1
Cell.Offset(i - 1, 0) = j
Tabela = Tabela & j & ";"
End If
Loop
End Sub

Sub jogar()
For i = 1 To Range("I1").Value
Teste
Next
End Sub

Sub Numeros_aleatorios_sem_duplicados()
Dim Tabel As New Collection
Dim i As Byte
Dim Valeur As Byte

On Error GoTo sbError

Do While i < 25
Valeur = Int(25 * Rnd) + 1
Tabel.Add Valeur, CStr(Valeur)
i = i + 1
Loop
For i = 1 To 25
Cells(i, 1) = Tabel(i)
Next i
Exit Sub

sbError:
i = i - 1
Resume Next

End Sub


'----------- F U N Ç Ã O E X T E N S O ----------------'
Function Extenso
( _
Valor As Currency, _
Optional MoedaNoSingular As String = "", _
Optional MoedaNoPlural As String = "", _
Optional CentavosNoSingular As String = "", _
Optional CentavosNoPlural As String = "") _
As String
Dim ParteInteira As Currency, ParteDecimal As Long
Dim s As String

ParteInteira = Fix(Valor)
ParteDecimal = Fix((Valor - ParteInteira) * 100)

s = ""
If ParteInteira > 0 Then
s = ConcatCentenas(ParteInteira)
If s = "um" Then 'ParteInteira = 1 ou 1.0 ou 1# não funciona
s = s & " " & MoedaNoSingular
Else
s = s & " " & MoedaNoPlural
End If
If ParteDecimal > 0 Then
s = s & " e "
End If
End If

If ParteDecimal > 0 Then
If ParteDecimal = 1 Then
s = s & "um " & CentavosNoSingular
Else
s = s & Centena(ParteDecimal) & " " & CentavosNoPlural
End If
End If
Extenso = s
End Function

Function Resto(A As Currency, B As Long) As Currency
Dim Aux As String, r As Currency
Aux = Format(A / B, "###0.0000")
Aux = Right$(Aux, 4)
Resto = Aux * B / 10000
If Resto < 1 And Resto > 0.99 Then
Resto = 1
End If
Aux = Format(Resto, "###0.0000")
Aux = Right$(Aux, 4)
Resto = Resto - Aux / 10000
End Function

Function DivInt(A As Currency, B As Long) As Currency
Dim Aux As String
DivInt = A / B
Aux = Format(DivInt, "###0.0000")
Aux = Right$(Aux, 4)
DivInt = DivInt - Aux / 10000
End Function

Private Function Unidade(N As Long) As String
Select Case N
Case 0
Unidade = ""
Case 1
Unidade = "um"
Case 2
Unidade = "dois"
Case 3
Unidade = "três"
Case 4
Unidade = "quatro"
Case 5
Unidade = "cinco"
Case 6
Unidade = "seis"
Case 7
Unidade = "sete"
Case 8
Unidade = "oito"
Case 9
Unidade = "nove"
Case Else
Err.Raise vbObjectError + 513, , "O número deve estar entre 0 e 9"
End Select
End Function

Private Function Dezena(N As Long) As String
Dim d As Long, u As Long
Dim s As String

d = N \ 10
u = N Mod 10

Select Case d
Case 0
Dezena = Unidade(N)
Exit Function
Case 1
Select Case u
Case 0
Dezena = "dez"
Case 1
Dezena = "onze"
Case 2
Dezena = "doze"
Case 3
Dezena = "treze"
Case 4
Dezena = "quatorze"
Case 5
Dezena = "quinze"
Case 6
Dezena = "dezesseis"
Case 7
Dezena = "dezessete"
Case 8
Dezena = "dezoito"
Case 9
Dezena = "dezenove"
End Select
Exit Function
Case 2
s = "vinte"
Case 3
s = "trinta"
Case 4
s = "quarenta"
Case 5
s = "cinqüenta"
Case 6
s = "sessenta"
Case 7
s = "setenta"
Case 8
s = "oitenta"
Case 9
s = "noventa"
Case Else
Err.Raise vbObjectError + 513, , "O número deve estar entre 0 e 99"
End Select

If u = 0 Then
Dezena = s
Else
Dezena = s & " e " & Unidade(u)
End If
End Function

Private Function Centena(N As Long) As String
Dim c As Long, d As Long
Dim s As String
c = N \ 100
d = N Mod 100

Select Case c
Case 0
Centena = Dezena(N)
Exit Function
Case 1
If d = 0 Then
Centena = "cem"
Else
Centena = "cento e " & Dezena(d)
End If
Exit Function
Case 2
s = "duzentos"
Case 3
s = "trezentos"
Case 4
s = "quatrocentos"
Case 5
s = "quinhentos"
Case 6
s = "seiscentos"
Case 7
s = "setecentos"
Case 8
s = "oitocentos"
Case 9
s = "novecentos"
Case Else
Err.Raise vbObjectError + 513, , "O número deve estar entre 0 e 999"
End Select

If d = 0 Then
Centena = s
Else
Centena = s & " e " & Dezena(d)
End If
End Function

Private Function SingleAlg(N As Currency) As Boolean
Dim s As String, i As Integer
s = N
SingleAlg = False
For i = 1 To Len(s)
If Mid$(s, i, 1) <> 0 Then
If SingleAlg Then
SingleAlg = False
Exit Function
Else
SingleAlg = True
End If
End If
Next i
End Function

Private Function ConcatCentenas(N As Currency) As String
Dim Trilhao As Long, Bilhao As Long, _
Milhao As Long, Milhar As Long, Um As Long, _
Menores As Integer
Dim s As String, m As Currency

s = ""
m = N

Um = Resto(N, 1000) 'Um = N Mod 1000
N = DivInt(N, 1000) 'N = N \ 1000
Milhar = Resto(N, 1000) 'Milhar = N Mod 1000
N = DivInt(N, 1000) 'N = N \ 1000
Milhao = Resto(N, 1000) 'Milhao = N Mod 1000
N = DivInt(N, 1000) 'N = N \ 1000
Bilhao = Resto(N, 1000) 'Bilhao = N Mod 1000
N = DivInt(N, 1000) 'N = N \ 1000
Trilhao = Resto(N, 1000) 'Trilhao = N Mod 1000000000

m = m - Trilhao * 1000000000000@
Menores = Bilhao + Milhao + Milhar + Um
If Trilhao > 0 Then
If Trilhao = 1 Then
s = "um trilhão"
Else
s = Centena(Trilhao) & " trilhões"
End If
If Menores > 0 Then
If SingleAlg(m) Then
s = s & " e "
Else
s = s & ", "
End If
Else
s = s & " de"
End If
End If

m = m - Bilhao * 1000000000@
Menores = Milhao + Milhar + Um
If Bilhao > 0 Then
If Bilhao = 1 Then
s = s & "um bilhão"
Else
s = s & Centena(Bilhao) & " bilhões"
End If
If Menores > 0 Then
If SingleAlg(m) Then
s = s & " e "
Else
s = s & ", "
End If
Else
s = s & " de"
End If
End If

m = m - Milhao * 1000000
Menores = Milhar + Um
If Milhao > 0 Then
If Milhao = 1 Then
s = s & "um milhão"
Else
s = s & Centena(Milhao) & " milhões"
End If
If Menores > 0 Then
If SingleAlg(m) Then
s = s & " e "
Else
s = s & ", "
End If
Else
s = s & " de"
End If
End If

m = -(Milhar * 1000) + m
Menores = Um
If Milhar > 0 Then
s = s & Centena(Milhar) & " mil"
If Menores > 0 Then
If SingleAlg(m) Then
s = s & " e "
Else
s = s & ", "
End If
End If
End If

s = s & Centena(Um)
ConcatCentenas = s
End Function



Aprenda tudo sobre planilhas do Aplicativo Microsoft Excel VBA(Visual Basic Application), sozinho, com baixo custo, praticando com os produtos didáticos Saberexcel





   Baixe o exemplo de planilha com as macros, funções e fórmulas acima.
Excel planilha vba jogos mega sena computador faz dez jogos aleatorios com interacoes (33.2 kB)



Publicidade:
Compre com garantia, segurança e ótimos preços nas lojas SubMarino.
Informática - Submarino.com.br

Tags:
Última atualização em Sáb, 13 de Agosto de 2011 19:16