vba - procv no form

[diego_janjao]

Pessoal, boa tarde.

 

Estou montando um formulário em VBA que alimentará um BD do access (o que não vem ao caso no momento) e gostaria que ao preencher a textbox de código (txt_codigo) ela automaticamente preenchesse o textbox Produto (txt_material):

 

Eu tentei algo como:

Private Sub txt_material_Change()

    On Error Resume Next ' minha dúvida está nessa parte
    If txt_codigo <> "" Then
    txt_material = Application.WorksheetFunction.VLookup((txt_codigo), Planilha1.Range("A1:B8"), 2, 0) '=PROCV(H2;A1:B3;2;0)
    Else
    txt_material.Value = ""
    End If

End Sub

mas não deu certo:

 

 

Alguém poderia me dar uma ajuda?

 

Seguem os arquivos: teste.zip

 

Desde já agradeço a ajuda.

[Basole]

Para preencher a txt_material, voce precisa utilizar o evento change da txt_codigo

E para localizar algo dentro do Excel, eu prefiro utilizar a função find.

Veja este exemplo:

Private Sub txt_codigo_Change()
Dim rng   As Range

With ThisWorkbook.Sheets("Planilha1")

  Set rng = .Columns("A").Find(txt_codigo.Text, LookIn:=xlValues, LookAt:=xlWhole)
        If Not rng Is Nothing Then
            txt_material.Text = rng.Offset(, 1).Value2 ' rng->(coluna A) | rng.Offset(, 1)->(coluna B)
        Else
            MsgBox txt_codigo.Text & " não localizado! Verifique!", 64, ""
        End If
    
End With
    
End Sub

 

 

[diego_janjao]

Perfeito, @Basole !

Aproveitando o seu conhecimento, qual termo eu devo pesquisar para que ao escolher um item no combobox só me apareçam os códigos pertinentes a ele em outro combobox?

 

Exemplo: Se escolho Estado de São Paulo, só me retorna as cidades desse estado.
 

[Basole]

Bom aproveitando o layout  da imagem abaixo, digamos que na coluna A temos os nomes de todas as cidades e na coluna B as siglas de todos os estados. Não há necessariamente a necessidade de classificar os dados, pode ficar junto e misturado.

Então aproveitando parte o código que postei acima, vamos considerar que temos a combobox1 (siglas-estado) e queremos carregar as cidades no combobox2

 

 

No evento Change ou Click da combobox1: 

Dim rng   As Range
Dim End1  As String

With ThisWorkbook.Sheets("Planilha1")

  Set rng = .Columns("B").Find(ComboBox1.Text, LookIn:=xlValues, LookAt:=xlPart)
        If Not rng Is Nothing Then 'rng ->(coluna B)
               End1 = rng.Address
            Do
               ComboBox.AddItem = rng.Offset(, -1).Value2 '->(coluna A)
            Set rng = .Columns("B").FindNext(rng)
            Loop While Not rng Is Nothing And End1 <> rng.Address
          
        Else
            MsgBox combobox1.text & " não localizado! Verifique!", 64, ""
        End If
    
End With

[diego_janjao]

@Basole , muito obrigado!

Vou tentar aqui (provavelmente dará certo) e se surgir mais alguma dúvida volto a postar aqui.

 

Novamente, muito obrigado.

adicionado 21 minutos depois

@Basole , infelizmente minha falta de conhecimento me fez travar aqui...
 

até onde entendo, para mim estava certo:

 

O erro acontece no AddItem

 

Aqui segue o arquivo:

 

Recebimento.zip

 

[Basole]

Sim esta certo, eu que errei e acrescentei um sinal de = (igual) onde não deveria. Retire o sinal que vai funcionar.

 

[Sasvki]

Caraca @Basole, dois coelhos com uma cajadada só, me salvou muito com essa solução, estava com um problema para achar um código com essa função para utilizar com uma combobox para preencher uma textbox, muito obrigado mesmo!

 

[Patropi]

sasaakii

 

Se foi útil, clique em curtir na resposta do Basole.

 

[]s

[diego_janjao]

@Basole mas ele não deveria retornar apenas 2 valores? 

 

[Basole]

Sim, a cada vez que voce clica no 1º combobox ele está acrescentando dados no 2º, use a propriedade .clear no inicio do codigo para limpar os dados antigos e carregar dados novos.

Ex.: 

txt_codigo.Clear

 

 

[diego_janjao]

@Basole Perfeito!

Muito obrigado! 

 

Gostaria apenas de mais uma dica:

Como eu estou salvando os dados em BD Access, eu gostaria que ao terminar o evento, quando surgisse o Msgbox dizendo que o material foi cadastrado com sucesso, que viesse a mensagem mostrando qual número de análise ele ficou cadastrado no banco.

 

Pois são 2 setores diferentes que a alimentarão por forms diferentes:

 

 

[Basole]

Veja se é isso: 

 MsgBox "Produto cadastrado com o nº de análise: " & _
            VBA.Format(Rs.Fields("Num_analise"), "0000/18") & _
            " com sucesso!", bInformation, "Controle de Recebimento"

 

[diego_janjao]

Mais uma vez, PERFEITO! @Basole

 

Obrigado, Basole!

 

 

[diego_janjao]

Pessoal, bom dia.

Ainda neste projeto, estou travado em uma parte:

Quando vou adicionar uma matéria prima nova, gostaria que o excel verificasse se esse código já está neste fornecedor, se caso sim, MsgBox avisando que já está incluída.

 

Tentei assim:

 

Private Sub btn_Padicionar_click()

    If Me.cb_fornecedor.Value = "" Or Me.txt_Pcodigo.Value = "" Then
    
    MsgBox "Preencha todos os campos para cadastrar uma matéria prima ao Fornecedor!", vbCritical, "Controle de Recebimento"
    
    Exit Sub
    
    End If

With Sheets("Produtos")

     o que = Me.cb_fornecedor.Text
     
     Set rng = .Columns(1).Offset(0, 1).Find(o que, LookIn:=xlValues, Lookat:=xlPart)
          
    If rng Is Nothing Then
    
    Application.ScreenUpdating = False
    
    Sheets("Produtos").Select
    
    Rows("6:6").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
    Range("A6").Select
    
        [A6] = Me.cb_fornecedor
        [B6] = Me.txt_Pcodigo
        [C6] = Me.txt_Pproduto
        [D6] = Environ("username") & " " & Now
                        
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWorkbook.Worksheets("Produtos").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Produtos").Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Produtos").Sort
        .SetRange Range("A2:D1500")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A2").Select
    Sheets("Início").Select
    
    MsgBox Me.txt_Pproduto & " cadastrada ao fornecedor " & Me.cb_fornecedor.Text, vbInformation, "Controle de Recebimento"
    
    Else
         MsgBox "Esta matéria prima já existe para este fornecedor!", vbCritical, "ATENÇÃO"

    End If
    
End With
        
End Sub

Mas não deu certo =/

 

DB_Recebimento.zip

[Basole]

Se esta tentando procurar pelo codigo, então tem que referenciar na busca pelo o campo Me.txt_Pcodigo (codigo).

E se a coluna de busca é a de codigos (B), então Columns(2) ou Columns("B")

Outra coisa, voce esta tentando inserir uma nova linha, na linha 6. Não entendi o motivo, mas a nova linha com os novos dados não podem ser inserida no final, já que depois disso há uma instrução de classificação dos dados ?

Veja a minha sugestão:  

Private Sub btn_Padicionar_click()
 Dim o que   As String
 Dim LR     As Long
 
 
        If Me.cb_fornecedor.Value = "" Or _
           Me.txt_Pcodigo.Value = "" Or _
           Me.txt_Pproduto.Text = "" Then
        
           MsgBox "Preencha todos os campos para cadastrar uma matéria prima ao Fornecedor!", vbCritical, _
                       "Controle de Recebimento"
        
        Exit Sub
        
        End If

With Sheets("Produtos")
     
        LR = .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row ' define ult. lin. vazia
        o que = txt_Pcodigo.Value ' campo q esta sendo procurado
     
    Set rng = .Columns(2).Find(o que, LookIn:=xlValues, Lookat:=xlPart)
          
    If rng Is Nothing Then
    
           .Range("A" & LR).Value = Me.cb_fornecedor.Text
           .Range("B" & LR).Value = Me.txt_Pcodigo.Text
           .Range("C" & LR).Value = Me.txt_Pproduto.Text
           .Range("D" & LR).Value = VBA.Environ("username") & " " & Now
         
           .Sort.SortFields.Clear
        
             LR = .Cells(Rows.Count, "A").End(xlUp).Row ' define ult. lin. c/ dados
          
           .Range("A2:D" & LR).Sort key1:=.Range("A2:A" & LR), _
                                  order1:=xlAscending, Header:=xlNo ' classifica os dados
                                        
      Sheets("Início").Activate
    
      MsgBox Me.txt_Pproduto & " cadastrada ao fornecedor " & Me.cb_fornecedor.Text, vbInformation, _
                                                                         "Controle de Recebimento"
    
    Else
         MsgBox "Esta matéria prima já existe para este fornecedor!", vbCritical, "ATENÇÃO"
    End If
    
End With
        
End Sub

 

[diego_janjao]

Eu tentei criar dessa forma com o evento de adicionar na última linha e depois ordenar mas não estava indo de maneira alguma, aí para "contornar" eu criei dessa forma.

 

Da forma que você escreveu está funcionando perfeitamente.

 

Mas eu sou muito burro, só me toquei agora que os dados de fornecedores e produtos não podem ser independentes do BD, pois se um setor cadastrar um novo fornecedor, outro setor pode acabar cadastrando o mesmo fornecedor com outro nome, e ficaria ruim de pesquisar... Aí depois de tudo que escrevemos, terei que mudar para puxar as informações do BD. 

 

[diego_janjao]

Depois da ********** que eu fiz, estou o dia todo aqui tentando fazer os combobox puxarem as informações do access, mas não estou tendo muito sucesso.

 

Até o momento o que consegui fazer foi o preenchimento automático do material de acordo com o que for digitado no código:

 

Recebimento - Puxando do access.zip

[Basole]

Não sei se entendi direito quais as tabelas e campos que voce quer popular os combobox, mas utilizei a tabela produtos

Coloquei a instrução para verif. e fechar o recordset pois ele é aberto no evento initialize

Private Sub UserForm_Activate()
  'carrega o combobox fornecedor:
    Me.cb_fornecedor.Clear
      
    sql = "SELECT * FROM  tblProdutos"

        If Rs.State = 1 Then ' ver. se recordset esta aberto
           Rs.Close
        End If
    
    Rs.Open sql, Miconexao, adOpenKeyset, adLockOptimistic, adCmdText 'abre o recordset junto com a conexao
        
            Do While Not Rs.EOF ' faz o loop ate o recordset for verdadeiro
                Me.cb_fornecedor.AddItem Rs.Fields("prod_Fornecedor")
                Rs.MoveNext
            Loop
       
    Rs.Close

End Sub

Ao selecionar um fornecedor, popula o codigo do produto no combobox codigo:

Private Sub cb_fornecedor_Change()
       
    Me.txt_codigo.Clear
    
    sql = "SELECT * FROM tblProdutos "
    sql = sql & "WHERE [prod_Fornecedor]= '" & Me.cb_fornecedor.Text & "'"
    
    If Rs.State = 1 Then
       Rs.Close
    End If
    
    Rs.Open sql, Miconexao, adOpenKeyset, adLockOptimistic, adCmdText
   
        Do While Not Rs.EOF
            Me.txt_codigo.AddItem Rs.Fields("prod_Codigo")
            Rs.MoveNext
        Loop
        
    Rs.Close
    
End Sub

 

[diego_janjao]

@Basole , bom dia primeiramente.

 

o local de onde eu deveria puxar os dados na Private Sub UserForm_Activate() seria da tblFornecedores, este eu consegui adaptar e está funcionando bem, já o código do produto, deveria puxar realmente da tblProdutos mas quando eu mudo seu código para puxar da tabela Produtos ele não popula:

 

Private Sub cb_fornecedor_Change()
       
    Me.txt_codigo.Clear
    
    sql = "SELECT * FROM tblProdutos "
    sql = sql & "WHERE [prod_Fornecedor]= '" & Me.cb_fornecedor.Text & "'"
    
    If Rs.State = 1 Then
       Rs.Close
    End If
    
    Rs.Open sql, Miconexao, adOpenKeyset, adLockOptimistic, adCmdText
   
        Do While Not Rs.EOF
            Me.txt_codigo.AddItem Rs.Fields("prod_Codigo")
            Rs.MoveNext
        Loop
        
    Rs.Close
    
End Sub

[Basole]

Estou enviando o arquivo que atualizei e esta populando os cados perfeitamente, pra ver se encontra algum erro ou inconsistência.

Recebimento - Puxando do access.zip

[diego_janjao]

@Basole , até funcionou conforme eu queria e como você fez, porém agora dá erro na parte de cadastrar:

 

DB_Recebimento.zip

 

 

 

[Basole]

Este erro, é porque ao popular os combobox a rs com os dados da tabela recebimento, foi fechada e aberta com os dados da tabela produtos, por isso que na rs atual (produtos),  não tinha os campos que voce relacionou.

É importante não deixar o usuario tentar salvar com os campos que requerem data,não estarem vazios, isso para não gerar erros pois os campos data do banco access, não aceitam nulos ou vazios. 

Segue o codigo com a alteração:.

 If Me.cb_fornecedor.Value = "" Or Me.txt_codigo.Value = "" Or _
       Me.txt_material.Value = "" Or Me.txt_fabricacao.Value = "" Or _
       Me.txt_validade.Value = "" Or Me.txt_notafiscal.Value = "" Or _
       Me.txt_quantidade.Value = "" Then
    
            MsgBox "Preencha todos os campos para cadastrar o produto!", vbInformation, "Controle de Recebimento"
    
    Exit Sub
    
    End If
             
       
       If Miconexao.State = 1 Then
            If Rs.State = 1 Then
               Rs.Close
            End If
        Else
            Call Conecta
       End If
       
    Rs.Open " SELECT * FROM tblRecebimento", Miconexao, adOpenKeyset, adLockOptimistic, adCmdText
             
             
    Rs.AddNew
        
        Rs.Fields("Data_Recebimento") = VBA.CDate(VBA.Date)
        Rs.Fields("Fornecedor") = Me.cb_fornecedor.Text
        Rs.Fields("Codigo") = Me.txt_codigo.Text
        Rs.Fields("Produto") = Me.txt_material.Text
        Rs.Fields("Lote") = Me.txt_lote.Text
        Rs.Fields("fabricação") = VBA.CDate(Me.txt_fabricacao.Text)
        Rs.Fields("validade") = VBA.CDate(Me.txt_validade.Text)
        Rs.Fields("Quantidade") = Me.txt_quantidade.Text
        Rs.Fields("Motorista") = Me.txt_motorista.Text
        Rs.Fields("Placa") = Me.txt_placa.Text
        Rs.Fields("NF") = Me.txt_notafiscal.Text
        Rs.Fields("Num_Pedido") = Me.txt_pedido.Text
        Rs.Fields("Cadastrado_por") = VBA.Environ("username")
        Rs.Fields("Horario") = VBA.CDate(VBA.Now)
        
            If Me.laudo_ok = True Then
                Rs.Fields("Laudo") = "OK"
            
            Else
            
                If Me.laudo_email = True Then
                    Rs.Fields("Laudo") = "Enviado por e-mail"
                
                Else
                
                    If Me.laudo_nok = True Then
                        Rs.Fields("Laudo") = "Laudo não enviado"
                               
                    End If
                
                End If
            End If
            
            
    Rs.Update
    
 MsgBox "Número de análise: " & _
            VBA.Format(Rs.Fields("Num_analise"), "0000/18") & " " & Rs.Fields("Fornecedor") & " - " & Rs.Fields("Produto") & _
            " cadastrado com sucesso!", bInformation, "Controle de Recebimento"
     
     If Rs.State = 1 Then
           Rs.Close
     End If

Esse menu suspenso ficou show de bola. Gostei!!

Mas reparei que quando clica em Lancar Recebimento, por exemplo, o sub-menu fica aberto. 

 

 

Minha dica, é chamar a rotina que fecha-o: 

Assim vai fechar automaticamente

Sub chamarform()
    
    Call XRecebimento_Clique
    form_Controle_Receb.Show
   
End Sub

[diego_janjao]

@Basole , bom dia. 

 

Muito obrigado pela força que está me dando nesse projeto e pelo aprendizado que está me proporcionando.

 

Essa parte que está dando erro eu ainda não conheço, por isso nem sei o que eu poderia fazer pra arrumar depois da alteração que você me indicou:

 

 

DB_Recebimento (2).zip

[Basole]

Neste caso no arquivo que voce enviou, só encontrei um erro referente ao nome do campo do bd access, campo

por exemplo.

E no código estava como "fabricação".

Segue o anexo corrigido:

Recebimento - Puxando do access.zip

[diego_janjao]

Putzz, muito obrigado. Ainda nem dormi mexendo nisso e não tinha reparado nisso. Muito obrigado.

 

Acredito que agora é acertar os demais campos que serão parecidos ou mais fáceis e "te darei uma folga", rs.

 

Novamente, muito obrigado.