Localizei por meio do Google. Grato, Hezequias.
Felipe, eu utilizo apenas uma planilha com as fórmulas, coisa simples de fazer.
Inserir dados na planilha e obenção dos resultados neste caso, se faz por meio de formulários.
Este pequeno aplicativo tem 22 form's dos quais 4 substituem as tradicionais MSGBOX para tornar o aplicativo mais agradável. Um formulário serve apenas para mostrar os resultados da auditoria e outro
serve como formulário inicial onde foram criados os botões que abrem todos os demais.
Quanto às fórmulas são as tradicionais de aritmética -- soma e subtração, usuais em contabilidade, nada excepcional e como disse fazem parte da planilha.
Segue abaixo o código de apenas um form. Os demais são cópia deste e poucos com pequenas alterações. O procedimento referido é este: Private Sub CmdSalvar_Click()
ThisWorkbook.Save
O código certamente não é a excelência de um programador mas é o que consegui depois de driblar muitas dificuldades.
Embora não tenha disposto, há também um módulo com código para remover ao caption.
Em síntese o codigo abaixo é repetido intriro ou em parte 17 vezes para que o aplicativo realize uma auditoria completa.
Option Explicit
Dim RetornoFinal As Boolean
Dim RetornoSalvar As Boolean
Dim RetornoSalva_Sai As Boolean
Dim r_OM As Long
Dim TotalLinhas_OM As Long
Dim Total_OM As String
Private Sub Cmd_Sair_Click() 'Salva somente se houve alteração ou insersaão de dados.
'--Usando operador AND(E) compara-se duas variáveis.
'--O resultado FALSO não permite salvar erroneamente o
'aplicativo ao clicar no botão SAIR, sem inserir dados ou logo após
'abrir o formulário.
'--Se não for salvo após a inserção ou correção de dados, o salvamento
'ocorrerá normalmente quado clicar no botão SAIR.
'--RetornoSalva_Sai é o retorno do botão Salvar.
'--RetornoSalvar é o retorno do Procedimento de Inserção, Limpar e Alteração.
'--RetornoFinal é o valor de saída do comparador AND.
If RetornoSalva_Sai = False And RetornoSalvar = False Then RetornoFinal = False
If RetornoSalva_Sai = False And RetornoSalvar = True Then RetornoFinal = True
If RetornoSalva_Sai = True And RetornoSalvar = False Then RetornoFinal = True
If RetornoFinal = True Then ThisWorkbook.Save
Unload Me
FrmRecibos.Show
End
End Sub
Private Sub CmdLimpar_Click()
'Limpa somente o conteúdo das células do range sem alterar a formatação.
Worksheets("plan1").Range("A1:A91") = ""
'Limpa o conteúdo do listbox e caixa de texto.
ListBox1.Clear
TextBox1 = "" 'limpa caixa de texto.
RetornoSalvar = True 'A ser comparada no procedimento Cmd_Sair.
Me.CmdSalvar.Visible = True
End Sub
Private Sub CmdSalvar_Click()
ThisWorkbook.Save
RetornoSalva_Sai = True 'A ser comparada no procedimento Cmd_Sair.
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim n1 As Variant
Dim n3 As Boolean
Dim validar As Integer
n3 = 0
'Detecta linha vasia na listbox e sai do procedimento.
If ListBox1.List(ListBox1.ListIndex) = Empty Then
Frm_LinhaSemValor.Show
n3 = False
Exit Sub
End If
Linhas:
'Corrige ou anula o valor de uma linha da listbox e grava na
'célula correspondente da planilha.
n1 = Application.InputBox(" DIGITE O NOVO VALOR NA FAIXA BRANCA", " ALTERANDO UM DONATIVO")
If (n1) = False Then 'Cancela a correção.
n3 = False
Exit Sub
End If
If IsNumeric(n1) Then 'Se for Número.
validar = 1
Else 'Se for Alfabeto.
validar = 2
End If
If n1 = "" Then 'Para Anular um Valor.
validar = 3
End If
Select Case validar 'Seleciona o evento correto.
Case validar = 1, validar = 2, validar = 3
'Caso Números
Case Is = 1
ListBox1.List(ListBox1.ListIndex) = n1
Cells(ListBox1.ListIndex + 1, "A") = CDbl(ListBox1)
n3 = True
'Caso Alfabeto.
Case Is = 2
Frm_Mensagem.Show
GoTo Linhas
'Caso Anular um Valor.
Case Is = 3
Frm_Exclusao.Show
If exclusao = False Then
Exit Sub
Else 'ANULA O VALOR DA LINHA SELECIONADA E SALVA NA PLANILHA.
n1 = 0
ListBox1.List(ListBox1.ListIndex) = n1
Cells(ListBox1.ListIndex + 1, "A") = CDbl(ListBox1)
n3 = True
End If
End Select
If n3 = False Then
RetornoSalvar = False 'A ser comparada no procedimento Cmd_Sair.
Else
RetornoSalvar = True 'A ser comparada no procedimento Cmd_Sair.
Me.CmdSalvar.Visible = True
End If
'Atualiza o valor da caixa de texto após a correção.
FRM_OM.TextBox1 = Worksheets("plan1").Range("A94").Value
End Sub
Private Sub Cmd_Inserir_Click()
Dim TotalLinhas As Long
Dim n1 As Variant ' String
n1 = 0
Dim n2 As Boolean
n2 = 0
Dim validar As Integer
'INÍCIO DE PREENCHIMENTO. TODAS AS CÉLULAS DEVEM ESTAR VAZIAS.
'Básicamente Selecciona a ultima celula da coluna e
'vai buscar a 1ª celula para cima que se encontra preenchida.
'Depois vai buscar o seu valor e por fim
'desloca-se para baixo de forma a colocar o valor que pretendes.
'O rótulo de linha a seguir simula um loop entre a 1º e a última
'linha vazia, mantendo o InputBox visível p/ todas as linhas.
Linhas:
'Verifica quantas linhas tem a coluna para dar tanto para o 2007 como anteriores
TotalLinhas = Range("A1:A91").Count
'Vai buscar o valor da ultima celula
Range("A" + CStr(TotalLinhas)).End(xlUp).Select 'Varre a coluna "A" em sentido decrescente, ou seja, de baixo para cima.
'Se a última célula estiver preenchida,as anteriores também estarão.Logo, abandona o procedimento.
If Range("A91").Value <> "" Then 'Se a última Célula da faixa selecionada não estiver vasia.
Frm_Completo.Show
n2 = False
Exit Sub
Else
'Verifica se a 1º célula está vasia.
If Range("A1").Value = "" Then 'INICIA O PREENCHIMENTO DA 1º CÉLULA.
n1 = Application.InputBox("ESCREVA UM VALOR NA CAIXA DE TEXTO ABAIXO:", _
" DONATIVOS PARA OBRA MUNDIAL")
If (n1) = False Then 'Cancela a insersão.
n2 = False
Exit Sub
End If
If n1 = "" Then 'Campo sem Valor.
n2 = False
GoTo Linhas
End If
If IsNumeric(n1) Then 'Se for Número.
validar = 1
Else 'Se for Alfabeto.
validar = 2
End If
Select Case validar 'Seleciona o evento correto.
Case validar = 1, validar = 2
'Caso Números
Case Is = 1
ActiveCell.Range("A1").Value = CDbl(n1) 'Ativa a primeira Célula e atribui o valor digitado.'CDbl converte inclusive as casas decimais.Converte para Double.
'Atualiza a ListBox
ListBox1.Clear
UserForm_Initialize
n2 = True
GoTo Linhas
'Caso Alfabeto.
Case Is = 2
Frm_Mensagem.Show
GoTo Linhas
End Select
End If
End If
'Identifica entrada ou alteração de dados p/ salvar ao sair.
'ESTE PROCEDURE NÃO ATIVA O BOTÃO SALVAR SE FOR COLOCADO NO FINAL DESTA
'FOLHA??? NÃO SEI POR QUE.
If n2 = False Then
RetornoSalvar = False 'A ser comparada no procedimento Cmd_Sair.
Else
RetornoSalvar = True 'A ser comparada no procedimento Cmd_Sair.
Me.CmdSalvar.Visible = True
End If
'PREENCHENDO TODAS AS OUTRAS CÉLULAS.
If Range("A1").Value <> "" Then 'Verifica se tem dados gravados na 1º célula antes de introduzir algum valor na 2º.
n1 = Application.InputBox("ESCREVA UM VALOR NA CAIXA DE TEXTO ABAIXO:", _
" DONATIVOS PARA OBRA MUNDIAL")
If (n1) = False Then 'Cancela a insersão.
n2 = False
Exit Sub
End If
If n1 = "" Then 'Campo sem Valor.
n2 = False
GoTo Linhas
End If
If IsNumeric(n1) Then 'Se for Número.
validar = 1
Else 'Se for Alfabeto.
validar = 2
End If
Select Case validar 'Seleciona o evento correto.
Case validar = 1, validar = 2
'Caso Números
Case Is = 1
ActiveCell.Offset(1, 0).Value = CDbl(n1) 'Desloca-se para a próxima Célula vasia Ativando-a e Transferindo o valor para ela.
'Atualiza a ListBox
ListBox1.Clear
UserForm_Initialize
n2 = True
GoTo Linhas
'Caso Alfabeto.
Case Is = 2
Frm_Mensagem.Show
GoTo Linhas
End Select
End If
End Sub
Private Sub UserForm_Initialize()
'FrmAtivo = 1 'Identifica FRM_OM no Frm_Mensagem.
'Call RemoveCaption(Me)
'Conta o nº de linhas do range.
TotalLinhas_OM = Range("A1:A91").Count
Range("A" + CStr(TotalLinhas_OM)).End(xlUp).Select
'Atribui o valor da célula à variável.
Total_OM = Worksheets("plan1").Range("A94").Value
'Prenche a listbox com os valores da OM.
For r_OM = 1 To TotalLinhas_OM
ListBox1.AddItem Cells(r_OM, "A")
Next r_OM
'Preenche a caixa de texto com o total para a OM.
TextBox1 = Total_OM
'Formulário maximizado
Application.WindowState = xlMaximized
Me.Height = Application.Height
Me.Width = Application.Width
Me.Left = Application.Left
Me.Top = Application.Top
'Botão de Comando Padrão
Me.Cmd_Sair.SetFocus
End Sub
Colar o código aqui misturou tudo, mas espero que dê p/ compreender o que tenho em mãos.
Grato pela ajuda.
Edison
