Usuário com melhor resposta
Filtro e Transpor

Pergunta
-
Pessoal, mais uma vêz conto com a ajuda de vocês.
Problema:
Preciso fazer um filtro em coluna "A" e "B":
A B
1 x
2 y
2 u
3 f
3 n
3 m
Filtrar valores não repetidos em "A", Colar em plan2 e transpor valores de "B" em seus respecivos valores em "A".
1 x
2 y/u
3 f/n/m
Espero que tenham entedido.
Eu tenho conseguido fazêlo com o filtro e a função transpor, porém só funciona para um valor de cada vêz.
Grato
oreste.jr@gmail.com
Respostas
-
Perfeito.
Muito obrigado pela oportunidade de aprendizado.
oreste.jr@gmail.com
- Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 23:45
Todas as Respostas
-
Sub Exemplo() Dim lRow As Long Dim wsEntrada As Worksheet Dim wsSaída As Worksheet Set wsEntrada = ThisWorkbook.Sheets("Plan1") Set wsSaída = ThisWorkbook.Sheets("Plan2") With wsEntrada .Cells.Sort Key1:=.Range("A1") wsSaída.Cells.ClearContents For lRow = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row wsSaída.Cells(.Cells(lRow, "A"), "A") = .Cells(lRow, "A") wsSaída.Cells(.Cells(lRow, "A"), "B") = wsSaída.Cells(.Cells(lRow, "A"), "B") & "/" & .Cells(lRow, "B") Next lRow End With With wsSaída For lRow = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row .Cells(lRow, "B") = Mid(.Cells(lRow, "B"), 2) Next lRow End With End Sub
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
-
-
Eu havia me confundido com os dados inicialmente fornecidos. Utilize a rotina abaixo:
Sub Exemplo() Dim lDe As Long Dim lPara As Long Dim wsDe As Worksheet Dim wsPara As Worksheet Set wsDe = ThisWorkbook.Sheets("Plan1") Set wsPara = ThisWorkbook.Sheets("Plan2") wsPara.Cells.Delete wsDe.Rows(1).Copy wsPara.Rows(1) For lDe = 2 To wsDe.Cells(wsDe.Rows.Count, "A").End(xlUp).Row lPara = fMatch(wsDe.Cells(lDe, "A"), wsPara.Columns("A")) If lPara = 0 Then lPara = fRowLast(wsPara.Columns("A")) + 1 wsPara.Cells(lPara, "A") = wsDe.Cells(lDe, "A") wsPara.Cells(lPara, "B") = wsPara.Cells(lPara, "B") & "/" & wsDe.Cells(lDe, "B") Next lDe With wsPara For lDe = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row .Cells(lDe, "B") = Mid(.Cells(lDe, "B"), 2) Next lDe End With End Sub Function fMatch(ByVal vTermo As Variant, ByVal vVetor As Variant) As Long 'Se vVetor for um objeto Range, retorna o número da linha ou coluna 'de uma célula com conteúdo vTermo numa linha ou coluna. 'Se vVetor for um vetor, retorna o índice do elemento vTermo no vetor. 'Caso não seja encontrada nenhuma ocorrência, é retornado 0. Dim Temp 'As Long On Error Resume Next Temp = WorksheetFunction.Match(CStr(vTermo), vVetor, 0) If Temp = 0 Then Temp = WorksheetFunction.Match(vTermo + 0, vVetor, 0) On Error GoTo 0 If Temp > 0 Then Select Case TypeName(vVetor) Case "Range" If vVetor.Columns.Count = 1 Then 'vVetor é uma coluna Temp = Temp + vVetor.Row - 1 ElseIf vVetor.Rows.Count = 1 Then 'vVetor é uma linha Temp = Temp + vVetor.Column - 1 End If End Select End If fMatch = Temp End Function Function fRowLast(rng As Range) As Long 'Retorna o número da última linha povoada do intervalo rng Dim Temp With rng On Error Resume Next Temp = .Find(What:="*" _ , After:=.Cells(1) _ , SearchDirection:=xlPrevious _ , SearchOrder:=xlByColumns _ , LookIn:=xlFormulas).Row If Temp = 0 Then Temp = rng.Cells(1).Row End With fRowLast = Temp End Function
Felipe Costa Gualberto - http://www.ambienteoffice.com.br
- Sugerido como Resposta Hezequias VasconcelosModerator sábado, 1 de dezembro de 2012 14:36
- Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 11:47
- Não Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 11:56
- Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 11:57
- Não Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 23:30
-
Perfeito.
Muito obrigado pela oportunidade de aprendizado.
oreste.jr@gmail.com
- Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 23:45