Saberexcel - o site das macros
Exemplo de Recibo que retorna o valor por extenso, como vários alunos havia pedido como aplicar a função de forma que preenchesse o extenso como se fosse um cheque. Observe que o exemplo você poderá desenvolver um " Preenche_Cheques". Espero que isso possa ajudá-los.
Fique com Deus. E_Marcondes

Option Explicit

'Essa função retorna o extenso de numero, se precisar baixe no final da página o exemplo de planilha.

Function Extenso(nValor As String) As String

If IsNull(nValor) Or nValor > 999999999.99 Then Exit Function

'Declara as variáveis da função
Dim intContador As Integer
Dim intTamanho As Integer
Dim strValor As String
Dim strParte As String
Dim strFinal As String
Dim strGrupo(4) As String
Dim strTexto(4) As String

'Define matrizes com extensos parciais
Dim strUnid(19) As String
strUnid(1) = "um ": strUnid(2) = "dois ": strUnid(3) = "três ": strUnid(4) = "quatro ": strUnid(5) = "cinco ": strUnid(6) = "seis ": strUnid(7) = "sete ": strUnid(8) = "oito ": strUnid(9) = "nove ": strUnid(10) = "dez ": strUnid(11) = "onze ": strUnid(12) = "doze ": strUnid(13) = "treze ": strUnid(14) = "quatorze ": strUnid(15) = "quinze ": strUnid(16) = "dezesseis ": strUnid(17) = "dezessete ": strUnid(18) = "dezoito ": strUnid(19) = "dezenove "
Dim strDezena(9) As String
strDezena(1) = "dez ": strDezena(2) = "vinte ": strDezena(3) = "trinta ": strDezena(4) = "quarenta ": strDezena(5) = "cinqüenta ": strDezena(6) = "sessenta ": strDezena(7) = "setenta ": strDezena(8) = "oitenta ": strDezena(9) = "noventa "
Dim strCentena(9) As String
strCentena(1) = "cento ": strCentena(2) = "duzentos ": strCentena(3) = "trezentos ": strCentena(4) = "quatrocentos ": strCentena(5) = "quinhentos ": strCentena(6) = "seiscentos ": strCentena(7) = "setecentos ": strCentena(8) = "oitocentos ": strCentena(9) = "novecentos "

'Divide o valor em vários grupos
strValor = Format$(nValor, "0000000000.00")
strGrupo(1) = Mid$(strValor, 2, 3) 'Milhão
strGrupo(2) = Mid$(strValor, 5, 3) 'Milhar
strGrupo(3) = Mid$(strValor, 8, 3) 'Centena
strGrupo(4) = "0" + Mid$(strValor, 12, 2) 'Centavo

'Processa cada grupo
For intContador = 1 To 4
strParte = strGrupo(intContador)

intTamanho = Switch(Val(strParte) < 10, 1, Val(strParte) < 100, 2, Val(strParte) < 1000, 3)
If intTamanho = 3 Then
If Right$(strParte, 2) <> "00" Then
strTexto(intContador) = strTexto(intContador) + strCentena(Left(strParte, 1)) + "e "
intTamanho = 2
Else
strTexto(intContador) = strTexto(intContador) + IIf(Left$(strParte, 1) = "1", "cem ", strCentena(Left(strParte, 1)))
End If
End If

If intTamanho = 2 Then
If Val(Right(strParte, 2)) < 20 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 2))
Else
strTexto(intContador) = strTexto(intContador) + strDezena(Mid(strParte, 2, 1))
If Right$(strParte, 1) <> "0" Then
strTexto(intContador) = strTexto(intContador) + "e "
intTamanho = 1
End If
End If
End If

If intTamanho = 1 Then
strTexto(intContador) = strTexto(intContador) + strUnid(Right(strParte, 1))
End If
Next intContador

'Gera o formato final do texto
If Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos")
Else
strFinal = ""
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões e ", "milhão e "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) <> 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) = 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões de ", "milhão de "), "")
End If
If Val(strGrupo(2)) = 0 And Val(strGrupo(3)) <> 0 And Val(strGrupo(4)) <> 0 Then
strFinal = strFinal + IIf(Val(strGrupo(1)) <> 0, strTexto(1) + IIf(Val(strGrupo(1)) > 1, "milhões, ", "milhão, "), "")
End If
If Val(strGrupo(3)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil ", "")
Else
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil e ", "")
Else
strFinal = strFinal + IIf(Val(strGrupo(2)) <> 0, strTexto(2) + "mil, ", "")
End If
End If
If Val(strGrupo(4)) = 0 Then
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais ")
Else
strFinal = strFinal + strTexto(3) + IIf(Val(strGrupo(3)) <> 1, IIf(Val(strGrupo(1) + strGrupo(2) + strGrupo(3)) = 1, "real ", "reais "), "real ")
End If
strFinal = strFinal + IIf(Val(strGrupo(4)) <> 0, "e " + strTexto(4) + IIf(Val(strGrupo(4)) = 1, "centavo", "centavos"), "")
End If
If Left(strFinal, 1) = "u" Then
Extenso = "H" & Mid$(strFinal, 1)
Else
Extenso = UCase(Mid$(strFinal, 1, 1)) & Mid$(strFinal, 2)
End If
Dim aux As String * 150
aux = Trim(Extenso) ' e alterar esta linha para trim(Extenso)
While Len(Trim(aux)) <> 150
aux = Trim(aux) & "-x"
Wend
Extenso = aux

End Function



Aprenda tudo sobre o Aplicativo Microsoft Excel VBA com Saberexcel

Saberexcel - o site de quem precisa aprender Macros Microsft Excel VBA.

Esses macros do aplicativo Micrososft Excel VBA, inserem uma borda na área ou célula selecionada, a intençao dos macros é ajudá-lo e facilitar a confecção de uma fatura, recibo, contrato e outros, pois há quem pena para fazer esses contratos, há uma maneira aparentemente mais simples, voce deverá primeiramente, autoajustar todas as linhas e colunas para começar o seu trabalho de distribuição de células com bordas para digitação mescladas ou nao. Espero que o exemplo possa lhe ser útil. Fique com Deus, Expedito Marcondes.


Sub Borda_I()
'
' Borda_I Macro
' Macro gravada por: Alunos (SaberExcel_VBA_Treinamentos®) Aprenda Microsoft Excel VBA (Saberexcel)
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
End Sub


Sub Borda_II()
'
' Borda_II Macro
' Macro gravada por: Alunos (SaberExcel_VBA_Treinamentos®) Aprenda Microsoft Excel VBA (Saberexcel)
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
End Sub

Sub Borda_III()
'
' Borda_III Macro
' Macro gravada por: Alunos (SaberExcel_VBA_Treinamentos®) Aprenda Microsoft Excel VBA (Saberexcel)
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = 50
End With
Range("Y6").Select
Range("AM23").Select
End Sub

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

Publicidade
Compre com segurança, garantia e ótimos preços