Excel Consulta com ListBox Condicional

[suelen_rch]

Olá

 

Não sou programadora, apenas uma curiosa no assunto vba.

 

Eu tenho um formulário no Excel que alimenta uma tabela na planilha Extrato.

 

No formulário, tem uma listbox listLancamentos que mostra os dados salvos nessa tabela.

 

Quero que, ao clicar na linha da listbox listLancamentos, os dados correspondentes àquela linha apareçam nos respectivos campo do forlurário: Id na textbox txtID, Data na textbox txtData, Vencimento na textbox txtVencimento, Tipo na combobox cboTipo, Cartão na combobox cboCartao, Conta na combobox cboConta, Situação na listbox listSituacao, Categoria na listbox listCategoria, Subcategoria na listbox listSubcategoria, Valor na textbox txtValor e Descrição na combobox cboDescrição.

 

A Listbox Categoria é preenchida dependendo do item selecionado na combobox Tipo e a Listbox Subcategoria é preenchida dependendo do item selecionado na Listbox Categoria.

 

Com a ajuda da internet, consegui chegar no código em anexo que, aparentemente, está funcionando.

 

O problema é que nem sempre as listbox estão mostrando a informação que está salva na planilha, que está totalmente preenchida. Às vezes a listbox carrega os dados e às vezes não. É como se a listbox perdesse o link com o índice da tabela ou não entendesse a varíavel.

 

Além disso, depois de clicar na linha da listbox Lançamentos, os dados aparecem nos outros controles e a listbox Lançamentos fica vazia.

 

Eu não estou conseguindo achar o que está causando esse erro. 

 

Alguém pode me ajudar?

 

Orçamento Pessoal.zip

[Midori]

O método que usou para retornar o valor da linha na função ProcuraIndiceRegistroPodId pode ser um problema no seu projeto. Se por algum motivo quiser inserir uma linha antes da tabela, terá que mudar o valor de indiceMinimo no código para retornar o valor correto. Além disso essa variável global pode ser pouco clara na manutenção do código já que esse valor 11 faz sentido para quem sabe o contexto dele.

 

Em vez disso, se aplicar a função Find será bem mais seguro já que assim vai retornar o valor correto da linha independente de qualquer inserção e também será mais rápido já que não será necessário usar loop.

 

Porém acho melhor usar um método mais simples para já retornar o registro. Isso pode ser feito passando para uma função o nome da coluna e o id para realizar a busca na tabela, p.ex,

 

Function BuscaRegistro(ByVal Id As Integer, ByVal NomeColuna As String) As String
    Dim Tabela      As ListObject
    Dim intColuna   As Integer
    Dim intId       As Integer
    Dim Linha       As Long
    
    Set Tabela = ThisWorkbook.Worksheets("Extrato").[tb_Extrato].ListObject
    intColuna = Tabela.ListColumns(NomeColuna).Index
    intId = Tabela.ListColumns("Id").Index

    If Not Tabela.DataBodyRange Is Nothing Then
        If WorksheetFunction.CountIf(Tabela.DataBodyRange.Columns(intId), Id) > 0 Then
            Linha = WorksheetFunction.Match(Id, Tabela.DataBodyRange.Columns(intId), 0)
            BuscaRegistro = Tabela.DataBodyRange(Linha, intColuna).Value
        End If
    End If
End Function

 

Assim é só passar os argumentos para a função e fazer as atribuições, p.ex,

Private Sub listLancamentos_Click()
    If listLancamentos.ListIndex > 0 Then
        Dim Id As Long
        
        Id = listLancamentos.List(listLancamentos.ListIndex, 0)
                 
        txtData.Value = BuscaRegistro(Id, "Data")
        txtVencimento = BuscaRegistro(Id, "Vencimento")
        txtValor = BuscaRegistro(Id, "Valor")
    End If
End Sub

 

4 horas atrás, suelen_rch disse:

a listbox Lançamentos fica vazia

Isso acontece porque alguns controles chamam o procedimento Filtra_listLancamentos no Change (evento ativado ao carregar esses controles) e lá tem o Clear do ListBox.

[suelen_rch]

Obrigada pelo retorno.

 

Eu tentei modificar o meu código conforme a sua sugestão, mas o problema ainda persiste. 

Tem vezes que o código roda perfeito e a listCategoria recebe o valor armazenado na coluna Categoria da planilha e, por consequência, a listSubcategoria também entende o valor armazenado na coluna Subcategoria da planilha, e tem vezes que a listCategoria recebe valor vazio (mesmo existindo string válida armazenada na coluna Categoria da planilha) e a listSubcategoria dá erro, porque ela depende do valor da listCategoria para ser preenchida. Testei tentando carregar o mesmo registro várias vezes.

 

 

 

Existe uma forma de contornar isso?

 

13 horas atrás, Midori disse:

Isso acontece porque alguns controles chamam o procedimento Filtra_listLancamentos no Change (evento ativado ao carregar esses controles) e lá tem o Clear do ListBox.

[Midori]

Está tentando carregar o ListBox com a propriedade Value em vez de AddItem. A atribuição simples que comentei serve para o TextBox. Para o list você pode chamar também em loop, p.ex: Call ListBox.AddItem(BuscaRegistro(Id, "Subcategoria")).

 

Se anexar o arquivo com as modificações será mais fácil ajudar.

[suelen_rch]

 

3 horas atrás, Midori disse:

Se anexar o arquivo com as modificações será mais fácil ajudar.

 

Segue o arquivo modificado em anexo.

 

Obrigada

 

Orçamento Pessoal.zip

[Midori]

Onde acontece o erro nas atribuições do List, se o seu excel for o 365, poderá usar a função RegistrosColuna do meu exemplo abaixo. Ou então faça com AddItem como antes.

 

Para não apagar o List você pode remover a chamada de Clear do procedimento.

 

***

 

Modifiquei a função BuscaRegistro com o acréscimo do parâmetro da tabela, fiz isso porque usei a referência a esse objeto em outras partes do código. Apliquei os registros nos ListBox com List no lugar de AddItem, veja que assim não precisa de loop para carregar os elementos.

 

O nome dos controles: cbxTipo, lbxLancamentos, lbxSituacao, txtDescricao, txtValor e txtSituacao.

 

 

 

Option Explicit

Private TabelaExtrato As ListObject

Private Sub UserForm_Initialize()
    Set TabelaExtrato = ThisWorkbook.Worksheets("Extrato").[tb_Extrato].ListObject
    
    If Not TabelaExtrato.DataBodyRange Is Nothing Then
        lbxLancamentos.ColumnWidths = "0;0;60;0;0;0;0;0;0;80;100"
        lbxLancamentos.ColumnCount = TabelaExtrato.DataBodyRange.Columns.Count
        lbxLancamentos.List() = RegistrosColuna(TabelaExtrato)
        lbxSituacao.List() = RegistrosColuna(TabelaExtrato, "Situação")
        cbxTipo.List() = RegistrosColuna(TabelaExtrato, "Tipo")
    End If
End Sub

Private Sub lbxLancamentos_Click()
    If lbxLancamentos.ListIndex >= 0 Then
        Dim Id  As Integer
        
        Id = lbxLancamentos.List(lbxLancamentos.ListIndex, 0)
        txtDescricao.Value = BuscaRegistro(TabelaExtrato, Id, "Descrição")
        txtSituacao.Value = BuscaRegistro(TabelaExtrato, Id, "Situação")
        txtValor.Value = BuscaRegistro(TabelaExtrato, Id, "Valor")
    End If
End Sub

Function RegistrosColuna(Tabela As ListObject, Optional ByVal NomeColuna As String) As Variant
    If Not Tabela.DataBodyRange Is Nothing Then
        If NomeColuna <> "" Then
            Dim intColuna   As Integer
            intColuna = Tabela.ListColumns(NomeColuna).Index
            RegistrosColuna = _
                WorksheetFunction.Sort( _
                    WorksheetFunction.Unique(Tabela.DataBodyRange.Columns(intColuna)))
        Else
            RegistrosColuna = Tabela.DataBodyRange
        End If
    End If
End Function

Function BuscaRegistro(Tabela As ListObject, ByVal Id As Integer, ByVal NomeColuna As String) As String
    Dim intColuna   As Integer
    Dim intId       As Integer
    Dim Linha       As Long
    
    intColuna = Tabela.ListColumns(NomeColuna).Index
    intId = Tabela.ListColumns("Id").Index

    If Not Tabela.DataBodyRange Is Nothing Then
        If WorksheetFunction.CountIf(Tabela.DataBodyRange.Columns(intId), Id) > 0 Then
            Linha = WorksheetFunction.Match(Id, Tabela.DataBodyRange.Columns(intId), 0)
            BuscaRegistro = Tabela.DataBodyRange(Linha, intColuna).Value
        End If
    End If
End Function

 

[suelen_rch]

O meu Excel não é o 365, a função RegistrosColuna dá erro de que não pe possível definir a propriedade unique da matriz.

 

Quando eu tento usar o .List no lugar do AddItem, dá erro de índice de matriz de propriedade inválido.

 

Se eu mantenho o carregamento com AddItem, mesmo com as modificações do seu exemplo, o problema ainda persiste.

 

 

 

 

[Midori]

Sem a função Unique pode ser feito com AddItem mesmo.

 

Para adicionar os elementos no list, fiz o procedimento AdicionaItem com um teste para não pegar item repetido, veja se assim resolve,

 

Option Explicit

Private TabelaExtrato   As ListObject

Private Sub UserForm_Initialize()
    Set TabelaExtrato = ThisWorkbook.Worksheets("Extrato").[tb_Extrato].ListObject
    If Not TabelaExtrato.DataBodyRange Is Nothing Then
        listLancamentos.ColumnWidths = "0;0;60;0;0;0;0;0;0;80;100"
        listLancamentos.ColumnCount = TabelaExtrato.DataBodyRange.Columns.Count
        listLancamentos.List() = TabelaExtrato.DataBodyRange.Value
        Call AdicionaItem(listSituacao, TabelaExtrato, "Situação")
        Call AdicionaItem(listCategoria, TabelaExtrato, "Categoria")
        Call AdicionaItem(listSubcategoria, TabelaExtrato, "SubCategoria")
    End If
End Sub

Private Sub listLancamentos_Click()
    If listLancamentos.ListIndex >= 0 Then
        Dim Id  As Integer
        Id = listLancamentos.List(listLancamentos.ListIndex, 0)
        txtData.Value = BuscaRegistro(TabelaExtrato, Id, "Data")
        txtId.Value = BuscaRegistro(TabelaExtrato, Id, "Id")
        txtValor.Value = BuscaRegistro(TabelaExtrato, Id, "Valor")
        txtVencimento.Value = BuscaRegistro(TabelaExtrato, Id, "Vencimento")
    End If
End Sub

Function BuscaRegistro(Tabela As ListObject, Id As Integer, NomeColuna As String) As String
    Dim intColuna   As Integer
    Dim intId       As Integer
    Dim Linha       As Long
    
    intColuna = Tabela.ListColumns(NomeColuna).Index
    intId = Tabela.ListColumns("Id").Index

    If Not Tabela.DataBodyRange Is Nothing Then
        If WorksheetFunction.CountIf(Tabela.DataBodyRange.Columns(intId), Id) > 0 Then
            Linha = WorksheetFunction.Match(Id, Tabela.DataBodyRange.Columns(intId), 0)
            BuscaRegistro = Tabela.DataBodyRange(Linha, intColuna).Value
        End If
    End If
End Function

Sub AdicionaItem(Controle As Object, Tabela As ListObject, NomeColuna As String)
    If Not Tabela.DataBodyRange Is Nothing Then
        Dim intColuna   As Integer
        Dim Linha       As Long
        
        intColuna = Tabela.ListColumns(NomeColuna).Index
        
        For Linha = 1 To Tabela.DataBodyRange.Rows.Count
            If WorksheetFunction.CountIf( _
                Tabela.DataBodyRange(1, intColuna).Resize(Linha), _
                Tabela.DataBodyRange(Linha, intColuna)) < 2 Then
                
                Call Controle.AddItem(Tabela.DataBodyRange(Linha, intColuna).Value)
            End If
        Next Linha
    End If
End Sub

 

[suelen_rch]

Bom dia.

 

Desculpe pela demora em responder.

 

Essa solução funcionou para o que eu preciso.

 

Em 10/05/2024 às 16:58, Midori disse:

Option Explicit

Private TabelaExtrato   As ListObject

Private Sub UserForm_Initialize()
    Set TabelaExtrato = ThisWorkbook.Worksheets("Extrato").[tb_Extrato].ListObject
    If Not TabelaExtrato.DataBodyRange Is Nothing Then
        listLancamentos.ColumnWidths = "0;0;60;0;0;0;0;0;0;80;100"
        listLancamentos.ColumnCount = TabelaExtrato.DataBodyRange.Columns.Count
        listLancamentos.List() = TabelaExtrato.DataBodyRange.Value
        Call AdicionaItem(listSituacao, TabelaExtrato, "Situação")
        Call AdicionaItem(listCategoria, TabelaExtrato, "Categoria")
        Call AdicionaItem(listSubcategoria, TabelaExtrato, "SubCategoria")
    End If
End Sub

Private Sub listLancamentos_Click()
    If listLancamentos.ListIndex >= 0 Then
        Dim Id  As Integer
        Id = listLancamentos.List(listLancamentos.ListIndex, 0)
        txtData.Value = BuscaRegistro(TabelaExtrato, Id, "Data")
        txtId.Value = BuscaRegistro(TabelaExtrato, Id, "Id")
        txtValor.Value = BuscaRegistro(TabelaExtrato, Id, "Valor")
        txtVencimento.Value = BuscaRegistro(TabelaExtrato, Id, "Vencimento")
    End If
End Sub

Function BuscaRegistro(Tabela As ListObject, Id As Integer, NomeColuna As String) As String
    Dim intColuna   As Integer
    Dim intId       As Integer
    Dim Linha       As Long
    
    intColuna = Tabela.ListColumns(NomeColuna).Index
    intId = Tabela.ListColumns("Id").Index

    If Not Tabela.DataBodyRange Is Nothing Then
        If WorksheetFunction.CountIf(Tabela.DataBodyRange.Columns(intId), Id) > 0 Then
            Linha = WorksheetFunction.Match(Id, Tabela.DataBodyRange.Columns(intId), 0)
            BuscaRegistro = Tabela.DataBodyRange(Linha, intColuna).Value
        End If
    End If
End Function

Sub AdicionaItem(Controle As Object, Tabela As ListObject, NomeColuna As String)
    If Not Tabela.DataBodyRange Is Nothing Then
        Dim intColuna   As Integer
        Dim Linha       As Long
        
        intColuna = Tabela.ListColumns(NomeColuna).Index
        
        For Linha = 1 To Tabela.DataBodyRange.Rows.Count
            If WorksheetFunction.CountIf( _
                Tabela.DataBodyRange(1, intColuna).Resize(Linha), _
                Tabela.DataBodyRange(Linha, intColuna)) < 2 Then
                
                Call Controle.AddItem(Tabela.DataBodyRange(Linha, intColuna).Value)
            End If
        Next Linha
    End If
End Sub

 

Obrigada pela ajuda!