7 - Extra / formulário

Postado por


Confira agora esse material extra sobre formulários ( userform ).


Nesta página, você aprenderá a criar um ótimo formulário com inúmeras ferramentas. Confira!


1 - Primeiro userform, parte1:

CÓDIGOS:
Sub FormularioTeste()
      Banco_Dados3.Show
End Sub
___________________________________
Private Sub Botao_Limpar_Click()
    Box01 = ""
    Box02 = ""
    Box03 = ""
    Box04 = ""
End Sub
___________________________________
 Private Sub Botao_Inserir_Click()
    'Copia a linha oculta com o gradiado e cola abaixo da última linha preenchida.
    Range("A2:E2").Select
    Selection.Copy
    Range("A1048576").End(xlUp).Select
    ActiveCell.Offset(1, 0).Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ 
         SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False

    'Copia a fórmula da coluna "A" da última linha prenchida e cola abaixo.   
    Range("A1048576").End(xlUp).Select 
    Selection.Copy
    ActiveCell.Offset(1, 0).Select
    ActiveSheet.Paste

    'Copia os valores dos BOXs e cola nas células da planilha. 
    ActiveCell.Offset(0, 1).Select
    ActiveCell = Box01
   
    ActiveCell.Offset(0, 1).Select
    ActiveCell = Box02
 
    ActiveCell.Offset(0, 1).Select 
    ActiveCell = Box03
 
    ActiveCell.Offset(0, 1).Select 
    ActiveCell = Box04

     'Limpa os BOXs do formulario 
     Box01 = ""
     Box02 = "" 
     Box03 = "" 
     Box04 = ""

    Application.CutCopyMode = False
    ActiveCell.Offset(0, -4).Select
End Sub
___________________________________
Private Sub Botao_Fechar_Click()
      Unload Banco_Dados3
End Sub


2 - Primeiro userform, parte2:

CÓDIGOS:
If Box01 = "" Then
       MsgBox "É necessário preencher todos os dados!"
       Exit Sub
End If
___________________________________ 
Private Sub Box01_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     'Critica somente texto
     If (KeyAscii > 47 And KeyAscii < 58) Then
         KeyAscii = 0
     End If
End Sub
 ___________________________________
Private Sub Box03_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     'Critica somente numeros inteiros
     If (KeyAscii < 48 Or KeyAscii > 57) And KeyAscii <> 8 Then
         KeyAscii = 0
     End If
End Sub


3 - Primeiro userform, parte3:

 
CÓDIGOS:
Private Sub Botao_Pesquisa_Click()
   If NuPes = "" Then
        MsgBox "É necessário inserir um número acima para se fazer a pesquisa!"
        Exit Sub
   End If

   Dim UCA As Integer
   UCA = Range("A1048576").End(xlUp).Value

   If NuPes > UCA Then
        MsgBox "O valor inserido é maior que o número total de torcedores: " & UCA & ""
        NuPes = ""
        Pes01 = ""
        Pes02 = ""
        Pes03 = ""
        Pes04 = ""
        Exit Sub
   End If

   With Worksheets(1).Range("a1:a5000")
        Set Resultado = .Find(NuPes, LookIn:=xlValues)
        Resultado.Select
  
       ActiveCell.Offset(0, 1).Select
       Pes01 = ActiveCell
  
       ActiveCell.Offset(0, 1).Select
       Pes02 = ActiveCell
  
       ActiveCell.Offset(0, 1).Select
       Pes03 = ActiveCell
  
       ActiveCell.Offset(0, 1).Select
       Pes04 = ActiveCell
  
       ActiveCell.Offset(0, -4).Select
   End With
End Sub___________________________________
Private Sub Botao_LimparPes_Click()
     NuPes = ""
     Pes01 = ""
     Pes02 = ""
     Pes03 = ""
     Pes04 = ""
End Sub


4 - Primeiro userform, parte4:

CÓDIGOS:
Private Sub Botao_Anterior_Click()
   If NuPes = "" Then
        MsgBox "É necessário que se faça uma pesquisa antes para se buscar dados anteriores!"
        Exit Sub
  End If

   If ActiveCell.Row < 9 Then
        MsgBox "Não é mais possível retroceder!"
        Exit Sub
   End If

   ActiveCell.Offset(-1, 0).Select
   NuPes = ActiveCell

   ActiveCell.Offset(0, 1).Select
   Pes01 = ActiveCell

   ActiveCell.Offset(0, 1).Select
   Pes02 = ActiveCell
  
   ActiveCell.Offset(0, 1).Select
   Pes03 = ActiveCell
  
   ActiveCell.Offset(0, 1).Select
   Pes04 = ActiveCell

  ActiveCell.Offset(0, -4).Select
End Sub
___________________________________
Private Sub Botao_Posterior_Click()
   If NuPes = "" Then
        MsgBox "É necessário que se faça uma pesquisa antes para se buscar dados posteriores!"
        Exit Sub
   End If

   If ActiveCell.Offset(1, 0) = "" Then
        MsgBox "Não é mais possível avançar!"
        Exit Sub
   End If

   ActiveCell.Offset(1, 0).Select
   NuPes = ActiveCell

   ActiveCell.Offset(0, 1).Select
   Pes01 = ActiveCell

   ActiveCell.Offset(0, 1).Select
   Pes02 = ActiveCell
  
   ActiveCell.Offset(0, 1).Select
   Pes03 = ActiveCell
  
   ActiveCell.Offset(0, 1).Select
   Pes04 = ActiveCell

   ActiveCell.Offset(0, -4).Select
End Sub
___________________________________
Private Sub Pes01_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
     'Critica não permitir que o campo PES01 seja preenchido.
     If (KeyAscii > 1 Or KeyAscii < 123) Then
          KeyAscii = 0
     End If  
End Sub


5 - Primeiro userform, parte5:

CÓDIGOS: 
Private Sub Botao_Deletar_Click()
    actRow = ActiveCell.Row

   If Pes01 = "" Then
          MsgBox "É necessário que se faça uma pesquisa antes para se excluir um torcedor!"
          Exit Sub
   End If

   If ActiveCell = "" Then
          MsgBox "Não é possível deletar esta linha!"
          Exit Sub
   End If
   
   Rows(actRow).Select
   Selection.Delete Shift:=xlUp
  
   Cells(actRow, "A").Select
  
   If ActiveCell = "" Then
       ActiveCell.Offset(-1, 0).Select
       NuPes = ActiveCell
     
       ActiveCell.Offset(0, 1).Select
       Pes01 = ActiveCell
     
       ActiveCell.Offset(0, 1).Select
       Pes02 = ActiveCell
     
       ActiveCell.Offset(0, 1).Select
       Pes03 = ActiveCell
     
       ActiveCell.Offset(0, 1).Select
       Pes04 = ActiveCell
     
       ActiveCell.Offset(0, -4).Select
   Else
       ActiveCell.Offset(0, 1).Select
       Pes01 = ActiveCell
       
       ActiveCell.Offset(0, 1).Select
       Pes02 = ActiveCell
       
       ActiveCell.Offset(0, 1).Select
       Pes03 = ActiveCell
       
       ActiveCell.Offset(0, 1).Select
       Pes04 = ActiveCell
       
       ActiveCell.Offset(0, -4).Select
   End If
  
   On Error GoTo MeuErro:
   Dim Escudo As String
   Escudo = Pes02
   Imagem1.Picture = LoadPicture("C:\Users\Nilton\Downloads\" & Escudo & ".jpg")
Exit Sub
  
MeuErro:
   Imagem1.Picture = LoadPicture("C:\Users\Nilton\Downloads\SemImagem.jpg")
End Sub


6 - Primeiro userform, parte6:

CÓDIGOS:
Private Sub ListaA_Click()
    NuPes = ListaA.List(ListaA.ListIndex, 0)
    Call Botao_Pesquisa_Click   
End Sub
___________________________________
Private Sub UserForm_Activate()
   Dim Lin As Integer 
   Dim LinBox As Integer
   Dim Aba As Worksheet
   Set Aba = Plan4

   Me.ListaA.Clear

   Lin = 8
   LinBox = 0

   With Aba
      Do Until Aba.Cells(Lin, 1).Value = Empty
        With ListaA
           .AddItem
           .List(LinBox, 0) = Aba.Cells(Lin, 1)
           .List(LinBox, 1) = Aba.Cells(Lin, 2)
        End With
        Lin = Lin + 1
        LinBox = LinBox + 1
 
      Loop
   End With
End Sub
___________________________________
As duas linhas abaixo são as linhas que foram acrescentadas aos códigos dos botões
Inserir, Pesquisar, Limpar Pesquisa, Anterior, Posterior e Deletar torcedor.
Call UserForm_Activate
ListaA = ListaA.List(NuPes - 1, 0)







Comentários

Postar um comentário