|
 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 o Aplicativo Microsoft Excel VBA com SaberExcel
 Baixe o exemplo de planilha com as macros, funções e fórmulas acima.
Publicidade:
Compre com garantia, segurança e ótimos preços nas lojas SubMarino. 
|