Skype:leandrofn84

Skype:leandrofn84
Skype:leandrofn84

segunda-feira, 11 de abril de 2011

Escrevendo por Extenso no Excel

O excel não tem uma função para escrever numero por Extenso? não tinha...
Copie estes códigos abaixo, clique Alt+F11, vai em inserir, modulo, cole os códigos, clique F11, feche o editor VBA, no excel digite a função =Extenso. Selecione a célula contendo o número e pronto, os trechos que contem ' significa comentário.

'Rotinas que processam um numero até 999.999.999,99     '
'e retorna-o em extenso                                 '
'Real e centavos                  '
Dim um_a_19
Dim dezenas
Dim centenas
Sub carregaVars()
um_a_19 = Array("", "um", "dois", "três", "quatro", "cinco", _
                "seis", "sete", "oito", "nove", "dez", _
                "onze", "doze", "treze", "quatorze", _
                "quinze", "dezasseis", "dezassete", _
                "dezoito", "dezanove")
               
dezenas = Array("", "dez", _
                "vinte", "trinta", "quarenta", "cinquenta", _
                "sessenta", "setenta", "oitenta", "noventa")
               
centenas = Array("cem", "cento", "duzentos", "trezentos", "quatrocentos", _
                  "quinhentos", "seiscentos", "setecentos", _
                  "oitocentos", "novecentos")
                 
End Sub

Function Extenso(numero As Double) As String
Dim ExtensoTemp As String
Dim XMilhoes, XMilhares, XCentenas, Centavos
Call carregaVars
If numero > 999999999.99 Then
   Extenso = "Erro - valor superior ao maximo:999.999.999,99"
   Exit Function
End If
num = Format(numero, "000000000.00")
XMilhoes = Processa(Mid(num, 1, 3))
XMilhares = Processa(Mid(num, 4, 3))
XCentenas = Processa(Mid(num, 7, 3))
Centavos = Right(num, 2)
Select Case Centavos
     Case Is <= 19
         extCentavos = um_a_19(Centavos)
     Case Is >= 20
         extCentavos = dezenas(Left(Centavos, 1)) & " " & um_a_19(Right(Centavos, 1))
End Select

If XMilhoes > "" Then
   If XMilhoes = "um" Then
      ExtensoTemp = ExtensoTemp & XMilhoes & " milhão "
   Else
      ExtensoTemp = ExtensoTemp & XMilhoes & " milhões "
   End If
End If
If XMilhares > "" Then
   If XMilhares = "um" And XMilhoes = "" Then
      ExtensoTemp = ExtensoTemp & "mil "
   Else
      ExtensoTemp = ExtensoTemp & XMilhares & " mil "
   End If
End If
If XCentenas > "" Then ExtensoTemp = ExtensoTemp & XCentenas
If extCentavos > "" Then
   ExtensoTemp = ExtensoTemp & " Real e " & extCentavos & " centavos"
Else
   ExtensoTemp = ExtensoTemp & " Reais"
End If
Extenso = UCase(ExtensoTemp)
End Function

Function Processa(num) As String
'Rotina utilizada para processar
'parcelas de um numero
'dividido em três posições
Dim n
n = Format(num, "000")
a1 = Val(Mid(n, 1, 1))
a2 = Val(Mid(n, 2, 1))
a3 = Val(Mid(n, 3, 1))
If a1 <> 0 And a2 & a3 = "00" Then
  
   If Val(a1 & a2 & a3) > 100 Then
      Processa = centenas(a1)
   Else
      Processa = centenas(a1 - 1)
   End If
  
ElseIf a1 > 0 And a2 >= 0 Then
 Select Case a3

  Case Is > 0
 
   If Val(a2 & a3) > 19 Then
      Processa = centenas(a1) & " e " & _
                 dezenas(a2) & " e " & _
                 um_a_19(a3)
   Else
      Processa = centenas(a1) & " e " & _
                 um_a_19(Val(a2 & a3))
   End If
 
  Case Is = 0
       Processa = centenas(a1) & " e " & dezenas(a2)

 End Select
  
ElseIf a1 = 0 Then
 Select Case Val(a2 & a3)
    Case Is < 20
       Processa = um_a_19(Val(a2 & a3))
    Case Else
       If um_a_19(a3) = "" Then
          Processa = dezenas(a2)
        Else
          Processa = dezenas(a2) & " e " & _
                 um_a_19(a3)
        End If
 End Select
Else
    Processa = ""
End If
End Function

Nenhum comentário:

Postar um comentário