Private Sub CommandButton1_Click()
Dim a As Long
Dim i As Long
Dim ulinhax As Long
Dim sprocurar As String
Dim eprocurado As Double
Dim counter As Long
Dim ulinha As Long
Dim UltimaLinha As Long
Application.ScreenUpdating = False
Labels
counter = 0
ulinhax = Plan1.Cells(Cells.rows.Count, 18).End(3).Row
sprocurar = VBA.Trim(Me.TextBox1.Text)
If VBA.Len(sprocurar) = 0 Then
MsgBox "NENHUM VALOR FOI DIGITADO! ", vbExclamation, "Atenção!"
TextBox1.Text = Empty
Me.TextBox1.SetFocus
Exit Sub
End If
eprocurado = VBA.CDbl(sprocurar)
sprocurar2 = VBA.Trim(Me.TextBox2.Text)
If VBA.Len(sprocurar2) = 0 Then
MsgBox "NENHUM VALOR FOI DIGITADO! ", vbExclamation, "Atenção!"
TextBox2.Text = Empty
Me.TextBox2.SetFocus
Exit Sub
End If
eprocurado2 = VBA.CDbl(sprocurar2)
UltimaLinha = Sheets("Plan1").Cells(Cells.rows.Count, 18).End(xlUp).Row
If UltimaLinha < Worksheets("Plan1").Range("AD1") Then UltimaLinha = Worksheets("Plan1").Range("AD1")
For i = Worksheets("Plan1").Range("AD1") To UltimaLinha
If Plan1.Cells(i, 18) = eprocurado And Plan1.Cells(i, 18).Font.Bold = True Then
MsgBox "VALOR DIGITADO REPETIDO! ", vbCritical, " ATENÇÃO!!!"
TextBox1 = ""
TextBox2 = ""
TextBox1.SetFocus
Exit Sub
End If
If Plan1.Cells(i, 4) = eprocurado2 And Plan1.Cells(i, 4).Font.Bold = True Then
MsgBox "VALOR DIGITADO REPETIDO! ", vbCritical, " ATENÇÃO!!!"
TextBox1 = ""
TextBox2 = ""
TextBox1.SetFocus
Exit Sub
End If
If Plan1.Cells(i, 18) = eprocurado And Plan1.Cells(i, 4) = eprocurado2 Then
Range("C" & i).Select
'Data
Range("C" & i).Font.Size = 11
Range("C" & i).Font.Bold = True
'Número Nota
'Range("D" & i).Font.Size = 11
'Range("D" & i).Font.Bold = True
'Range("D" & i).Font.Color = RGB(192, 0, 0)
'UF
Range("E" & i).Font.Size = 11
Range("E" & i).Font.Bold = True
'CFOP
Range("F" & i).Font.Size = 11
Range("F" & i).Font.Bold = True
'Valor ST
Range("R" & i).Font.Bold = True
Range("R" & i).Font.Color = RGB(0, 0, 0)
Range("R" & i).Font.Size = 11
'Linha Razão Social
Range("V" & i).Font.Size = 10
Range("V" & i).Font.Bold = True
Range("V" & i).Font.Color = RGB(192, 0, 0)
'Número da Linha
Range("AB" & i).Font.Size = 10
Range("AB" & i).Font.Color = RGB(166, 166, 166)
'ActiveCell.FormulaR1C1 = "=RC[-6]"
'Hora
Plan1.Cells(i, 29).Value = time
Plan1.Cells(i, 29).Font.ColorIndex = 25
Plan1.Cells(i, 29).Font.Size = 8
TextBox1 = ""
TextBox2 = ""
TextBox1.SetFocus
counter = counter + 1
'Módulo PassarTraços
Call ContornoCélulas
End If
Next i
' If counter = 0 Then
'
' MsgBox "VALOR DIGITADO NÃO ENCONTRADO! ", vbCritical, "ERRO"
' TextBox1 = ""
' TextBox2 = ""
' Label3 = ""
' TextBox1.SetFocus
''==============PROCURA NÚMERO DA NOTA===============
'
' ElseIf TextBox2.Text <> "" Then
'
' Dim UltLinhatx As Long
' Dim k As Long
'
' UltLinhatx = Sheets("Plan1").Cells(Cells.rows.Count, 4).End(xlUp).Row
'
' If UltLinhatx < Worksheets("Plan1").Range("AD1") Then UltLinhatx = Worksheets("Plan1").Range("AD1")
'
' For k = Worksheets("Plan1").Range("AD1") To UltLinhatx
'
' If CDbl(TextBox2.Text) = CDbl(Range("D" & k).Text) Then
' Range("D" & k).Font.Name = "Book Antiqua"
' Range("D" & k).Font.Size = 11
' Range("D" & k).Font.Bold = True
' Range("D" & i).Font.Color = RGB(221, 217, 196)
' Range("C" & i).Select
' TextBox1 = ""
' TextBox2 = ""
' Me.TextBox1.SetFocus
'
' Exit For
'
'Else
'
' If k = UltLinhatx Then
' MsgBox "NOTA FISCAL NÃO ENCONTRADA! ", vbCritical, "ERRO"
' TextBox2 = ""
' Me.TextBox2.SetFocus
'
' End If
' End If
' Next k
' End If
End Sub
Private Sub CommandButton2_Click()
'Call Formatar_Linha_MG
Range("D10000").End(xlUp).Offset(1, -1).Select
Unload UserForm1
'UserForm2.Show
End Sub
Private Sub TextBox1_Change()
'Comando para apagar "UF" quando digitar outro valor
If UserForm1.TextBox1 <> "" Then
Label3 = ""
Frame1.BackColor = &HC0FFFF
Label3.BackColor = &HC0FFFF
End If
'==========================================================================
'Código para colocar ponto e virgula automaticamente na TextBox1
Dim valor
Dim numPonto
Dim numVirgula
valor = TextBox1.Value
If IsNumeric(valor) Then
If InStr(1, valor, "-") >= 1 Then valor = Replace(valor, "-", "")
If InStr(1, valor, ",") >= 1 Then valor = CDbl(Replace(valor, ",", ""))
If InStr(1, valor, ".") >= 1 Then valor = Replace(valor, ".", "")
Select Case Len(valor)
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 = Pontuacao(8, valor)
Case 12 To 14
numPonto = Pontuacao(11, valor)
Case Else
numPonto = valor
End Select
numVirgula = Left(numPonto, Len(numPonto) - 2) & "," & Right(numPonto, 2)
TextBox1.Value = numVirgula
Else
If Me.TextBox1.Text = "p" Then
Unload UserForm1
UserForm6.Show
UserForm6.TextBox101.SetFocus
UserForm6.TextBox101 = ""
Exit Sub
End If
If valor = "" Then Exit Sub
MsgBox " Não digite vírgula ou letras!", vbCritical, "Atenção..."
TextBox1.Text = ""
Exit Sub
End If
End Sub
Private Sub CommandButton3_Click()
Unload UserForm1
UserForm6.Show
End Sub
Public Sub Labels()
Dim x As Range
Dim sLin
Dim UL
Dim PL, c
sLin = 10
If Me.TextBox1 = "" Then
Exit Sub
End If
UL = Plan1.Range("R65536").End(xlUp).Row '.Value 'definir a UL(UltimaLinha)
PL = Plan1.Range("R10").End(xlUp).Row '.Value 'definir a PL(Primeira Linha)
Set x = Plan1.Range("R" & UL & ":" & "R" & 10)
For Each c In x
If CStr(c.Value) = CStr(TextBox1) Then
Me.Label3 = Plan1.Range("E" & sLin).Value
Frame1.BackColor = &HFFFFFF
Label3.BackColor = &HFFFFFF
End If
sLin = sLin + 1
Next
If Label3 = "MG" Then
MsgBox " Para o Estado de MG não paga GNRE!", vbCritical, "Atenção..."
TextBox1 = ""
TextBox2 = ""
TextBox1.SetFocus
End If
End Sub
Private Sub TextBox2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Limita a Qde de caracteres
TextBox2.MaxLength = 6
End Sub
Function Pontuacao(inicio, valor)
'Função da pontuação na TextBox1
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
Pontuacao = i & "." & M1 & "." & f
Else
Pontuacao = i & "." & M1 & "." & M2 & "." & f
End If
End Function
Este post foi modificado 4 anos atrás 3 vezes por
AndersonEm 90% dos casos em que não se anexa o arquivo, ocorrem mal-entendidos, gerando perda de tempo de ambos os lados.
Postado : 08/11/2020 11:37 am