Dim Lg As Single
Dim Ht As Single
Dim Fini As Boolean
Private Sub btn_calcular_Click()
Dim quantidade, sv1, sv2 As Long
Dim strEmpresa, strObservacoes, strBusca As String
Dim datPeriodo As Date
Dim ei, compras, ef, vendas As Currency
Dim resultado As Double
Dim novoRegistro As Boolean
Dim lngUltLinDados, lngPriLinDados, lngLoopLin As Long
lngPriLinDados = 2
With wshDados
lngUltLinDados = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
trataErro:
'TRATAMENTO DE DADOS PARA IMPEDIR O CADSTRO SEM O PREENCHIMENTO DE ALGUNS TXTBOX
With Me
If .txt_empresa = "" Then
MsgBox ("Preenchimento incompleto! Insira Empresa"), vbExclamation, aviso
.txt_empresa.SetFocus
Exit Sub
ElseIf .txt_periodo = "" Then
MsgBox ("Preenchimento incompleto! Insira Período"), vbExclamation, aviso
.txt_periodo.SetFocus
Exit Sub
ElseIf .txt_ei = "" Then
MsgBox ("Preenchimento incompleto! Insira EI"), vbExclamation, aviso
.txt_ei.SetFocus
Exit Sub
ElseIf .txt_compras = "" Then
MsgBox ("Preenchimento incompleto! Insira Compras"), vbExclamation, aviso
.txt_compras.SetFocus
Exit Sub
ElseIf .txt_ef = "" Then
MsgBox ("Preenchimento incompleto! Insira EF"), vbExclamation, aviso
.txt_ef.SetFocus
Exit Sub
ElseIf .txt_vendas = "" Then
MsgBox ("Preenchimento incompleto! Insira Vendas"), vbExclamation, aviso
.txt_vendas.SetFocus
Exit Sub
End If
End With
With Me
'Havendo erro na conversão, vá para
'o parágrafo de tratamento "trataErro:"
On Error GoTo trataErro
datPeriodo = .txt_periodo.Text
strEmpresa = .txt_empresa.Text
ei = .txt_ei.Text
compras = .txt_compras.Text
ef = .txt_ef.Text
vendas = .txt_vendas.Text
strObservacoes = .txt_observacoes.Text
End With
novoRegistro = True
'FAZ A VARREDURA NA PLANILHA EM BUSCA POR DADOS SEMELHANTES
With wshDados
For lngLoopLin = lngPriLinDados To lngUltLinDados Step 1
strBusca = wshDados.Cells(lngLoopLin, 2) & wshDados.Cells(lngLoopLin, 3)
If strBusca = datPeriodo & strEmpresa Then
If MsgBox("Empresa " & strEmpresa & " já cadastrado para o " & datPeriodo & " , deseja sobrescreve-lo?!", vbYesNo) = vbYes Then
.Cells(lngLoopLin, 2) = datPeriodo
.Cells(lngLoopLin, 3) = strEmpresa
.Cells(lngLoopLin, 4) = CCur(ei)
.Cells(lngLoopLin, 5) = CCur(compras)
.Cells(lngLoopLin, 6) = CCur(ef)
.Cells(lngLoopLin, 7) = CCur(vendas)
.Cells(lngLoopLin, 10) = strObservacoes
If opt1.Value = Enabled Then
.Cells(lngLoopLin, 11) = "Industria"
Else
.Cells(lngLoopLin, 11) = "Comércio"
End If
novoRegistro = False
End If
novoRegistro = False
End If
Next lngLoopLin
'SE NÃO HOUVER DADOS SEMELHANTES, ENTÃO NOVO REGISTRO
If novoRegistro = True Then
Call numeracao_automatica
.Cells(lngUltLinDados + 1, 2) = datPeriodo
.Cells(lngUltLinDados + 1, 3) = strEmpresa
.Cells(lngUltLinDados + 1, 4) = CCur(ei)
.Cells(lngUltLinDados + 1, 5) = CCur(compras)
.Cells(lngUltLinDados + 1, 6) = CCur(ef)
.Cells(lngUltLinDados + 1, 7) = CCur(vendas)
.Cells(lngUltLinDados + 1, 10) = strObservacoes
If opt1.Value = Enabled Then
.Cells(lngLoopLin, 11) = "Industria"
Else
.Cells(lngLoopLin, 11) = "Comércio"
End If
Else
Exit Sub
End If
'CALCULO PARA DETERMINAR MVA% QUE SERÁ CARREGADA NO TXT_RESULTADO
sv1 = CDbl(.Cells(lngUltLinDados + 1, 6).Value2) + CDbl(.Cells(lngUltLinDados + 1, 7).Value2)
sv2 = CDbl(.Cells(lngUltLinDados + 1, 4).Value2) + CDbl(.Cells(lngUltLinDados + 1, 5).Value2)
resultado = (sv1 - sv2) / sv2
.Cells(lngUltLinDados + 1, 8).Value = resultado
'formatação nas celulas da coluna 8
.Cells(lngUltLinDados + 1, 8).NumberFormat = "0.00%"
'formatação do txt_resultado
txt_resultado.Value = Format(.Cells(lngUltLinDados + 1, 8).Value, "#.#0%")
If opt1.Value = False Then
If resultado <= 0.8 Then
.Cells(lngUltLinDados + 1, 9).Value = "Comércio"
.Cells(lngUltLinDados + 1, 9).Value = "OK"
MsgBox ("Resultado MVA% = " & Format(.Cells(lngUltLinDados + 1, 8).Value, "#.#0%") & " , STATUS: " & .Cells(lngUltLinDados + 1, 9).Value & "")
MsgBox "Dados cadastrados com sucesso! Deseja realizar um novo registro?!", vbYesNo
Call UserForm_Initialize
Else
.Cells(lngUltLinDados + 1, 9).Value = "Comércio"
.Cells(lngUltLinDados + 1, 9).Value = "CUSTO<20%"
MsgBox ("Resultado MVA% = " & Format(.Cells(lngUltLinDados + 1, 8).Value, "#.#0%") & " , STATUS: " & .Cells(lngUltLinDados + 1, 9).Value & "")
MsgBox "Dados cadastrados com sucesso! Deseja realizar um novo registro?!", vbYesNo
Call UserForm_Initialize
End If
Else
'resultado menor ou igual a 60% e o opt.value = ativo
If resultado <= 0.6 Then
.Cells(lngUltLinDados + 1, 9).Value = "Indústria"
.Cells(lngUltLinDados + 1, 9).Value = "OK"
MsgBox ("Resultado MVA% = " & Format(.Cells(lngUltLinDados + 1, 8).Value, "#.#0%") & " , STATUS: " & .Cells(lngUltLinDados + 1, 9).Value & "")
MsgBox "Dados cadastrados com sucesso! Deseja realizar um novo registro?!", vbYesNo
Call UserForm_Initialize
Else
.Cells(lngUltLinDados + 1, 9).Value = "Indústria"
.Cells(lngUltLinDados + 1, 9).Value = "CUSTO<40%"
MsgBox ("Resultado MVA% = " & Format(.Cells(lngUltLinDados + 1, 8).Value, "#.#0%") & " , STATUS: " & .Cells(lngUltLinDados + 1, 9).Value & "")
MsgBox "Dados cadastrados com sucesso! Deseja realizar um novo registro?!", vbYesNo
Call UserForm_Initialize
End If
End If
' MsgBox ("Resultado MVA% = " & Format(.Cells(lngUltLinDados + 1, 8).Value, "#.#0%") & " , STATUS: " & .Cells(lngUltLinDados + 1, 9).Value & "")
End With
' MsgBox "Dados cadastrados com sucesso! Deseja realizar um novo registro?!", vbYesNo
' Call UserForm_Initialize
End Sub
Private Sub img_calendario_Click()
txt_periodo.Value = GetCalendário
End Sub
Private Sub Label8_Click()
Application.Visible = True
Call volta_exibir
Me.Hide
End Sub
Private Sub Label18_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' Label18_Click
End Sub
Private Sub UserForm_Initialize()
Dim i As Integer, L As Integer, TB
Call limpar
InitMaxMin Me.Caption
Ht = Me.Height
Lg = Me.Width
Application.ScreenUpdating = False
With frm_estoque
.txt_empresa.SetFocus
.btn_calcular.Enabled = True
.opt1.Value = False
End With
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Resize()
Dim RtL As Single, RtH As Single
If Me.Width < 300 Or Me.Height < 200 Or Fini Then Exit Sub
RtL = Me.Width / Lg
RtH = Me.Height / Ht
Me.Zoom = IIf(RtL < RtH, RtL, RtH) * 100
End Sub
Private Sub UserForm_Terminate()
Application.Visible = True
ActiveWorkbook.Save
'Application.Quit
Fini = True
End Sub
Private Sub limpar()
txt_empresa = ""
txt_periodo = ""
txt_ei = ""
txt_compras = ""
txt_ef = ""
txt_vendas = ""
txt_resultado = ""
txt_observacoes = ""
End Sub
Private Sub btn_consultar_Click()
frm_consulta.Show
End Sub
Sub numeracao_automatica()
Dim i
i = wshDados.Cells(Rows.Count, 1).End(xlUp).Row + 1
For j = 2 To i
If IsNumeric(wshDados.Cells(j - 1, 1)) Then
wshDados.Cells(j, 1) = wshDados.Cells(j - 1, 1) + 1
Else
wshDados.Cells(j, 1) = 1
End If
Next
End Sub
Private Sub txt_periodo_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
txt_periodo.MaxLength = 10
Select Case KeyAscii
Case 8
Case 13: SendKeys "{TAB}"
Case 48 To 57
If txt_periodo.SelStart = 2 Then txt_periodo.SelText = "/"
If txt_periodo.SelStart = 5 Then txt_periodo.SelText = "/"
Case Else: KeyAscii = 0
End Select
End Sub
Private Sub txt_ei_Change()
'créditos do código - Bruno Sobral (http://excelevba.com.br/formato-moeda-no-textbox-enquanto-digita/)
valor = txt_ei.Value
If IsNumeric(valor) Then
If InStr(1, valor, "-") >= 1 Then valor = Replace(valor, "-", "") 'retira sinal negativo
If InStr(1, valor, ",") >= 1 Then valor = CDbl(Replace(valor, ",", "")) 'retirar a virgula
If InStr(1, valor, ".") >= 1 Then valor = Replace(valor, ".", "") 'para trabalhar melhor retiramos ponto
Select Case Len(valor) 'verifica casas para inserção de ponto
Case 1
numPonto = "00" & valor
Case 2
numPonto = "0" & valor
Case 6 To 8
numPonto = Left(valor, Len(valor) - 5) & "." & Right(valor, 5)
Case 9 To 11
numPonto = inseriPonto(8, valor)
Case 12 To 14
numPonto = inseriPonto(11, valor)
Case Else
numPonto = valor
End Select
numVirgula = Left(numPonto, Len(numPonto) - 2) & "," & Right(numPonto, 2)
txt_ei.Value = numVirgula
Else
If valor = "" Then Exit Sub
MsgBox "Número invalido", vbCritical, "Caracter Invalido"
Exit Sub
End If
End Sub
Private Sub txt_compras_Change()
valor = txt_compras.Value
If IsNumeric(valor) Then
If InStr(1, valor, "-") >= 1 Then valor = Replace(valor, "-", "") 'retira sinal negativo
If InStr(1, valor, ",") >= 1 Then valor = CDbl(Replace(valor, ",", "")) 'retirar a virgula
If InStr(1, valor, ".") >= 1 Then valor = Replace(valor, ".", "") 'para trabalhar melhor retiramos ponto
Select Case Len(valor) 'verifica casas para inserção de ponto
Case 1
numPonto = "00" & valor
Case 2
numPonto = "0" & valor
Case 6 To 8
numPonto = Left(valor, Len(valor) - 5) & "." & Right(valor, 5)
Case 9 To 11
numPonto = inseriPonto(8, valor)
Case 12 To 14
numPonto = inseriPonto(11, valor)
Case Else
numPonto = valor
End Select
numVirgula = Left(numPonto, Len(numPonto) - 2) & "," & Right(numPonto, 2)
txt_compras.Value = numVirgula
Else
If valor = "" Then Exit Sub
MsgBox "Número invalido", vbCritical, "Caracter Invalido"
Exit Sub
End If
End Sub
Private Sub txt_ef_Change()
valor = txt_ef.Value
If IsNumeric(valor) Then
If InStr(1, valor, "-") >= 1 Then valor = Replace(valor, "-", "") 'retira sinal negativo
If InStr(1, valor, ",") >= 1 Then valor = CDbl(Replace(valor, ",", "")) 'retirar a virgula
If InStr(1, valor, ".") >= 1 Then valor = Replace(valor, ".", "") 'para trabalhar melhor retiramos ponto
Select Case Len(valor) 'verifica casas para inserção de ponto
Case 1
numPonto = "00" & valor
Case 2
numPonto = "0" & valor
Case 6 To 8
numPonto = Left(valor, Len(valor) - 5) & "." & Right(valor, 5)
Case 9 To 11
numPonto = inseriPonto(8, valor)
Case 12 To 14
numPonto = inseriPonto(11, valor)
Case Else
numPonto = valor
End Select
numVirgula = Left(numPonto, Len(numPonto) - 2) & "," & Right(numPonto, 2)
txt_ef.Value = numVirgula
Else
If valor = "" Then Exit Sub
MsgBox "Número invalido", vbCritical, "Caracter Invalido"
Exit Sub
End If
End Sub
Private Sub txt_vendas_Change()
valor = txt_vendas.Value
If IsNumeric(valor) Then
If InStr(1, valor, "-") >= 1 Then valor = Replace(valor, "-", "") 'retira sinal negativo
If InStr(1, valor, ",") >= 1 Then valor = CDbl(Replace(valor, ",", "")) 'retirar a virgula
If InStr(1, valor, ".") >= 1 Then valor = Replace(valor, ".", "") 'para trabalhar melhor retiramos ponto
Select Case Len(valor) 'verifica casas para inserção de ponto
Case 1
numPonto = "00" & valor
Case 2
numPonto = "0" & valor
Case 6 To 8
numPonto = Left(valor, Len(valor) - 5) & "." & Right(valor, 5)
Case 9 To 11
numPonto = inseriPonto(8, valor)
Case 12 To 14
numPonto = inseriPonto(11, valor)
Case Else
numPonto = valor
End Select
numVirgula = Left(numPonto, Len(numPonto) - 2) & "," & Right(numPonto, 2)
txt_vendas.Value = numVirgula
Else
If valor = "" Then Exit Sub
MsgBox "Número invalido", vbCritical, "Caracter Invalido"
Exit Sub
End If
End Sub
Function inseriPonto(inicio, valor)
i = Left(valor, Len(valor) - inicio)
M1 = Left(Right(valor, inicio), 3)
M2 = Left(Right(valor, 8), 3)
F = Right(valor, 5)
If (M2 = M1) And (Len(valor) < 12) Then
inseriPonto = i & "." & M1 & "." & F
Else
inseriPonto = i & "." & M1 & "." & M2 & "." & F
End If
End Function