Selecionando dados na Listbox1, como transferir dados repetidos de folha excell para listbox2.

Question

Boa noite, Amigos.

Tenho um Userform que contem 3 listbox e uma textbox. Digitando letras na textbox, vão aparecendo na listbox1 as strings que contêm os carateres digitados na textbox.

Até aqui, tudo bem. No entanto, quando seleciono uma linha na textbox1, pretendia que os dados da folha Excell, relativos a essa linha, numa determinada coluna e linha, passassem para a listbox2 e listbox3. Até aqui, também se consegue.

O meu problema é então o seguinte:

Existem na coluna "D" da folha nomes repetidos, que contêm informações diferentes nas colunas "F" e "J".

O que preciso é um código que ao selecionar na listbox1 os dados relativos a um nome, o Excell procure outras ocorrências relativas a esse nome e que mostre na listbox2 em linhas separadas, por exemplo pelos carateres "============", as outras ocorrencias relativas a esse nome na coluna "F". Pela mesma lógica conseguir o mesmo na listbox3 com os dados da coluna "J".

O resultado que se pretende obter terá pois este aspeto:

listbox2:

===============================

Referenciado ao HGO. Possivel lesão cervical.

===============================

Referenciado à Ginecologia

listbox3:

===============================

Landormin-12/12

===============================

Ginocanestene

Caso possam ajudar, fico imensamente agradecido.

Abraços e Festas Felizes para todos.

M_A_L

Answer 1

"No entanto, quando seleciono uma linha na textbox1"

Estou considerando que o certo é ListBox1, certo?

---

Teria como você disponibilizar sua pasta de trabalho para analisarmos a estrutura e propor uma solução?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 2

Boa noite, Filipe.

Estou considerando que o certo é ListBox1, certo?

Mencionei dessa forma apenas como exemplo, mas penso que não é relevante.

No meu caso concreto, a listbox3 responde ao evento click. Em função do click num item da listbox3, deverá ser preenchida a listbox1 com os dados da coluna "F" e a listbox2 será preenchida com os dados da coluna "J".

Como posso disponibilizar o ficheiro?

O Forum, não me deixa inserir imagens nem consigo descobrir como anexar ficheiros.

No entanto segue o código que estou a tentar fazer funcionar:

Option Explicit

Sub FillListBox()
Sheets("DADOS").Select
Sheets("DADOS").Unprotect
Dim start As Integer
  ListBox3.Clear
  start = 2
  While Range("DADOS!D" & start).Value <> ""
' ----LINHAS NÃO UTILIZADAS -----
'ListBox1.ColumnCount = 5
'ListBox1.ColumnWidths = "45;220;40;90;30"

    If InStr(1, Range("DADOS!D" & start).Value, TextBox1.Value, vbTextCompare) >= 1 Then
      ListBox3.AddItem Range("DADOS!D" & start).Value & "  -----  " & _
      Range("DADOS!E" & start).Value & "  -----  " & _
      Range("DADOS!G" & start).Value & "  ..................  " & _
      Range("DADOS!C" & start).Value & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & vbTab & start
    End If
 
     If TextBox1.Value = "" Then
ListBox3.Clear

    End If
    start = start + 1
  Wend
End Sub

Private Sub TextBox1_Change()
ListBox3.Clear
ListBox1.Clear
ListBox2.Clear
 
 FillListBox
End Sub
Private Sub ListBox3_Click()
 Dim lin As Integer
  lin = 1 * Mid(ListBox3.Value, InStr(1, ListBox3.Value, vbTab & vbTab, vbTextCompare))
  
If InStr(1, Range("DADOS!D" & lin).Value, TextBox1.Value, vbTextCompare) >= 1 Then
 Dim lLast As Long
    Dim lRow As Long
    
    With Sheets("DADOS")
    lLast = .Cells(.Rows.Count, "C").End(xlUp).Row
        
 Do While Range("DADOS!C" & lLast).Value = Range("DADOS!C" & lLast + lRow).Value
        For lRow = 2 To lLast
        
        If Range("DADOS!C" & lLast).Value = Range("DADOS!C" & lLast + 1).Value Then
            ListBox1.AddItem "=============" & Range("DADOS!B" & lin).Value & "=============="
            ListBox1.AddItem Range("DADOS!H" & lLast).Value
            ListBox2.AddItem "=============" & Range("DADOS!B" & lin).Value & "=============="
            ListBox2.AddItem Range("DADOS!I" & lLast).Value
        End If
        Next lRow
  Loop
        
            ListBox1.AddItem "=============" & Range("DADOS!B" & lin).Value & "=============="
            ListBox1.AddItem Range("DADOS!H" & lin).Value
            ListBox2.AddItem "=============" & Range("DADOS!B" & lin).Value & "=============="
            ListBox2.AddItem Range("DADOS!I" & lin).Value
        
            Label112.Caption = Range("DADOS!G" & lin).Value
            Label115.Caption = Range("DADOS!D" & lin).Value
            Label116.Caption = Range("DADOS!E" & lin).Value
            Label113.Caption = Range("DADOS!F" & lin).Value
            Label114.Caption = Range("DADOS!J" & lin).Value
    End With
End If
End Sub

Aguardo indicações de como anexar o ficheiro.

Um grande obrigado pelo interesse em ajudar e continuação de BOAS FESTAS.

Abraço

M_A_L

Answer 3

Ainda assim preciso de um anexo. Você pode anexar num site como o SendSpace ou no seu SkyDrive: http://www.ambienteoffice.com.br/outros/como_disponibilizar_um_arquivo_para_download/

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 4

Boa noite Filipe.

Como não estou familiarizado com o SkyDrive, ainda não abri conta, mas vou fazê-lo em breve.

Como tal, enviei o ficheiro para o e-mail constante no link que disponibilizou. ( felipebenza@.......).

Espero que me desculpe por isso.

Em jeito de explicação, o problema encontra-se no Formulário "Histórico".

Grato pela Ajuda que o seu Elevado Profissionalismo puder prestar, envio desde já os votos de um excelente 2014.

Cumprimentos

M_A_L

Answer 5

Muito obrigado.

Sem problemas sobre o arquivo, no entanto, não chegou nada em meu e-mail ainda.

Sobre o SkyDrive, só de você conseguir postar neste fórum, você automaticamente já tem uma conta SkyDrive. Acho que se você digitar o endereço http://www.skydrive.com, abrirá a tela de seus arquivos da nuvem.

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 6

Boa noite, Filipe.

Depois da sua chamada de atenção sobre o SkyDrive, verifiquei que tinha já esse espaço que vem do tempo do antigo Messenger e do qual já nem me lembrava, pois já não o uso há anos.

De qualquer forma o e-mail que enviei, não retornou qualquer mensagem de erro e reencaminhei de novo.

Mas criei então uma pasta e julgo que fiz tudo direitinho apesar de as instruções do seu site estarem bem diferentes das configurações atuais.

Desta forma, tente aceder ao ficheiro pelo link que envio:

https://skydrive.live.com/redir?resid=EEE3B7A606CED5BF!498&authkey=!AMaMLnTPzqyCbqo&ithint=file%2c.xlsm

Em jeito de explicação, tal como disse no e-mail, se no form principal clicar no botão "HISTÓRICO", verá um outro form. É neste que está o problema "Userform1_HISTORICO", no evento listbox3_click.

Um grande agradecimento e post um comentário se não conseguir aceder ao ficheiro.

Muito, muito Obrigado.

M_A_L

 

Answer 7

Olá,

Na verdade, agora que percebi que recebi seu e-mail. Eu não fazia ideia que o seu nome é Manuel :-)

Sobre sua dúvida, estou encontrando discrepâncias entre sua postagem original explicando o problema e a estrutura da pasta de trabalho que  me enviou. Por exemplo, na coluna D eu possuo a idade dos pacientes. Você não quis referenciar a coluna C?

Além disso, você chegou a tentar montar um formulário com código ou não? Abri o arquivo indicado do SkyDrive e não havia nenhum formulário e nenhuma macro.

No aguardo.

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 8

Boa noite, Filipe.

o Post inicial, era apenas de exemplo e se por acaso desse para fazer um código sem o envio do ficheiro eu adaptaria.

O ficheiro que recebeu por e-mail, contempla uma busca por idades, mas no final, aquilo que pretende e que estou a usar de momento é a busca por nomes. Esse ficheiro contempla idades, para eu ir fazendo testes com as idades, já que existem idades repetidas. No entanto, a busca final, tanto pode ser feita por idades como por nomes. Esse facto não é relevante.

No Sky, anexei o ficheiro tal como o tenho gravado, um pouco mais completo do que o que recebeu por e-mail.

Vou tentar anexar no skydrive de novo e julgo que o link será o mesmo.

https://skydrive.live.com/redir?resid=EEE3B7A606CED5BF!496&authkey=!AEglOjMEF7Yb5wQ&ithint=folder%2c.xlsm

Se conseguir anexar devidamente, verificará que a rotina que não funcionava, já funciona. Falta apenas polir um pouco.

Anexei de novo, no entanto dá-me a seguinte informação:

---------------------------------------------------------------------

Relatório de compatibilidade.

Não é possível apresentar as seguintes funcionalidades do browser:

.Projeto VBA

.Formas ou outros objetos

Mas pode abrir o ficheiro no Excel para ver todos os conteúdos do livro.

Mais informações

---------------------------------------------------------------

Editei a pasta foruns, pode ser que agora seja possível.

O forum não me deixa colar imagens, pois diz que não posso fazê-lo sem que possam verificar a minha conta.

Não sei o que possa fazer quanto a isto.

Abraços

M_A_L

Answer 9

Primeiramente, algumas considerações do SkyDrive:

Sobre o link ser o mesmo, normalmente é isso mesmo o que ocorre. Se você alterar um arquivo do seu SkyDrive e salvar, o link não muda. No entanto, se você sobrescrever o arquivo com outro de mesmo nome, não sei o que acontece.

Se você tiver o Excel instalado em sua máquina, sugiro que baixe o arquivo do SkyDrive abra na sua máquina, uma vez que o Excel Web Apps (o Excel online do browser, que abre as pastas de trabalho do SkyDrive) tem funcionalidades limitadas. Conforme notificado, ele não suporta executar nenhum tipo de código VBA e não mostra alguns tipos de formas em planilhas.

---

Sobre sua dúvida: crie um formulário com uma caixa de texto (TextBox1) e três caixas de listagem (ListBox1, ListBox2 e ListBox3), cole o código abaixo no formulário e execute. Esse código é válido para a última pasta de trabalho que você disponibilizou:

Dim mwksDados As Excel.Worksheet
Dim mclcNomes As VBA.Collection

Private Sub ListBox1_Click()
  Dim lngRow As Long
  
  Me.ListBox2.Clear
  Me.ListBox3.Clear
  If Me.ListBox1.ListIndex = -1 Then Exit Sub
  
  With mwksDados
    For lngRow = 2 To .Cells(.Rows.Count, "C").End(xlUp).Row
      If .Cells(lngRow, "C").Value = Me.ListBox1.Value Then
        Me.ListBox2.AddItem .Cells(lngRow, "F").Value
        Me.ListBox3.AddItem .Cells(lngRow, "J").Value
      End If
    Next lngRow
  End With
End Sub

Private Sub TextBox1_Change()
  Dim lng As Long
  Dim str As String
  
  Me.ListBox1.Clear
  Me.ListBox2.Clear
  Me.ListBox3.Clear
  For lng = 1 To mclcNomes.Count
    str = VBA.UCase(mclcNomes(lng))
    If str Like "*" & VBA.UCase(Me.TextBox1.Value) & "*" Then
      Me.ListBox1.AddItem str
    End If
  Next lng
End Sub

Private Sub UserForm_Initialize()
  Dim lng As Long
  Dim str As String
  
  Set mwksDados = ThisWorkbook.Worksheets("DADOS")
  Set mclcNomes = New Collection
  
  With mwksDados
    On Error Resume Next
    For lng = 2 To .Cells(.Rows.Count, "C").End(xlUp).Row
      str = .Cells(lng, "C").Value
      mclcNomes.Add str, str
    Next lng
    On Error GoTo 0
  End With
End Sub

Private Sub UserForm_Terminate()
  Set mwksDados = Nothing
  Set mclcNomes = Nothing
End Sub

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 10

Bom dia, Filipe.

Não sei se tomou em consideração o meu último post. Quando inseri o ficheiro de novo, já não me apresentou a mensagem de funcionalidades limitadas.

Presumo que depois de alterar permissões na pasta "FORUNS", algo tenha mudado, daí que pensei que daria para você editar, pois é essa a configuração que dei à pasta.

O arquivo foi inserido de novo e o link fornecido foi o do último post.

Como por certo pode reparar e conforme disse no último post, a rotina em falta que motivou esta postagem, já está a funcionar (pode verificar no arquivo completo mais recente que enviei por e-mail). Falta apenas polir o código, como por exemplo atribuir colunas nas listbox 1 e 2, embora a lstbox1 já esteja a funcionar dessa forma.

Ao tentar abrir o arquivo, o computador pergunta se quero abrir com excel ou excel Wap.

Para todos os efeitos, vou pegar no seu código e adaptar, pois o formulário já está criado como pode verificar pelo arquivo enviado por e-mail.

Vai por certo funcionar.

Qualquer coisa, dou retorno.

Como se diz no Brasil, Obrigadão cara.

Um grande abraço e obrigado pela disponibilidade.

M_A_L

Answer 11

Uma excelente tarde para si, Felipe.

Depois de substituir o código que tinha agregado ao formulário pelo que me enviou, houve algumas mensagens de erro por diferença de nomes, mas depressa se regularizou essa cena.

O código em si, é simplesmente fantástico e faz exatamente o que se pretende, exceto na busca que não apresenta os nomes repetidos, quando é o caso. No entanto julgo que não é importante, pois ao clicar nesse nome, aparecem todas as referências que estão registadas.

Alterei a estrutura do formulário e pretendo nas listbox1 e 2, introduzir colunas e inserir mais dados nessas colunas, como por exemplo o tipo de consulta.

Neste caso, com o seu código, se um doente tiver 10 consultas, apenas se consegue visualizar o último tipo de consulta registado e é necessária a informação das outras, assim, introduzo-as na textbox.

Para todos os efeitos, este é um código potente, que responde com exatidão àquilo que lhe é solicitado e que por certo faria mais, se o programador soubesse o que vai na cabeça de quem delineou esta mini aplicação e também as necessidades de quem o vai utilizar.

Do excelente Engº Informático que é, eu não esperava outra coisa a não ser um excelente código.

Peço desculpa por lhe ter chamado Filipe, mas só agora reparei que assina os posts como Felipe. Pensava que era apenas no e-mail.

Vou aguardar um pouco antes de marcar como respondido, para ver se consigo com o seu código escalonar as listbox por colunas.

Um enorme abraço de Portugal e um excelente ano 2014 para si e seus entes queridos.

Muito, muito obrigado.

M_A_L

Answer 12

Boa noite, Felipe.

É assim, está 5 estrelas.

Ficou impecável.

Quem sabe, sabe e não há mais nada a dizer.

Você é um espetáculo.

Só lhe peço mais um favor.

Se reparar no ficheiro que enviei por e-mail, se escolher a opção guardar como... e atribuir outro nome, dá um erro de dibug numa label da folha. Tem como resolver isso?

Muito grato pelo tempo que perdeu comigo, envio cordiais cumprimentos.

Um grande 2014 para si.

BOM ANO.

M_A_L

Answer 13

Obrigado pelos elogios, Manuel. Desejo a você um excelente 2014 também.

Sobre o erro que está tendo ao "Guardar Como", não consegui reproduzir.

É um erro de macro? Se sim, em qual linha?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 14

Boa noite, Felipe.

Não são elogios, é tão sómente dizer a verdade. É um erro de código, ou macro, e encontra-se no evento mousemove da folha 1. Folha de rosto do livro. A rotina tem apenas 3 linhas e na 2ª linha na instrução label1.visible=true, acontece esse erro de dibug sempre que gravo com outro nome.

No entanto ele grava o ficheiro. Depois do erro clicando apenas em gravar, tudo fica normal.

Felipe, tenha paciência. Só mais um favor.

Na rotina que me facultou em 29 de Dez, nesta mesma postagem, tento inserí-la na pag. 5 de um Multipage.

Com as devidas alterações de nome nos objetos, tudo funciona em pleno, exceto uma coisa, a mais necessária.

Para evitar erros de digitação nos nomes, queria que ao clicar no nome que aparece na listbox, o código me colocasse esse nome na textbox_nome, de forma que ao clicar no Btn gravar esse nome fosse acrescentado na folha exatamente com a mesma grafia.

Pensava que bastava alterar as linhas que sublinhei:

Private Sub ListBox4_Click()
  Dim lngRow As Long
  
  If Me.ListBox4.ListIndex = -1 Then Exit Sub
  
  With mwksDados
    For lngRow = 2 To .Cells(.Rows.Count, "C").End(xlUp).Row
      If .Cells(lngRow, "C").Value = Me.ListBox4.Value Then
Me.ListBox2.AddItem .Cells(lngRow, "F").Value
Me.ListBox3.AddItem .Cells(lngRow, "J").Value
      End If
    Next lngRow
  End With
End Sub

e substí-las por:

        TextBox_nome.Value = Me.ListBox4.Value
        UserForm_RegistoConsultas.MultiPage_Historico.Value = 0

Acontece que já tentei de várias formas mas não me grava o nome selecionado na textbox. Também não dá qualquer erro. Terá que ser substituído todo o código?

Coloquei todas as linhas inclusive no evento activate e terminate.

Um abraço

                           FELIZ                2014

M_A_L

Answer 15

Sobre o problema do mouse:

Private Sub Image1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  On Error Resume Next
  Label1.Visible = True
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
  On Error Resume Next
  Label1.Visible = False
End Sub

---

Sobre a caixa de listagem, você tem essa expressão:

TextBox_nome.Value = Me.ListBox4.Value

No entanto, Me.ListBox4.Value retorna o valor que está selecionado numa caixa de listagem.

Se você quer retornar o primeiro valor que está presente na caixa de listagem, use algo como Me.ListBox4.List(0)

Tentou essas alternativas?

---

Felipe Costa Gualberto - http://www.ambienteoffice.com.br

Answer 16

Felipe.

Obrigado pela resposta.

Com Me.ListBox4.List(0), dava-me mensagem de erro.

Resolvi no entanto desta forma:

Private Sub ListBox4_Click()
Sheets("DADOS").Unprotect

  Dim lngRow As Long, Nome As String
  
  If Me.ListBox4.ListIndex = -1 Then Exit Sub
  
  With mwksDados
    For lngRow = 2 To .Cells(.Rows.Count, "C").End(xlUp).Row
      If .Cells(lngRow, "C").Value = Me.ListBox4.List(0) Then
      End If
    Next
  End With

End Sub

Retirei as instruções de clear, e após a seleção do nome, introduzi:

Private Sub CommandButton8_Click()
    UserForm_RegistoConsultas.TextBox_nome.Value = Me.ListBox4.Value
    UserForm_RegistoConsultas.MultiPage_Historico.Value = 0
    TextBox8.Value = ""
    ListBox4.Clear
End Sub

Bateu certinho.

A mensagem de erro, bateu certinho também.

Muitíssimo obrigado.

As maiores felicidades. Até ao próximo post.

Um abraço

M_A_L