none
Filtro e Transpor RRS feed

  • 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

    quinta-feira, 29 de novembro de 2012 14:29

Respostas

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

    quinta-feira, 29 de novembro de 2012 22:47
    Moderador
  • Felipe, disponibilizei o arquivo em: http://www.sendspace.com/file/uy12ch.

    O evento não está sendo terminado, está dando uma mensagem de erro.

    Digitei na pla2 a forma como deveria ser finalizado.

    Obrigado pelo apoio.


    oreste.jr@gmail.com

    sexta-feira, 30 de novembro de 2012 11:28
  • 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
    sexta-feira, 30 de novembro de 2012 23:23
    Moderador
  • Perfeito.

    Muito obrigado pela oportunidade de aprendizado.


    oreste.jr@gmail.com

    • Marcado como Resposta orestejunior segunda-feira, 3 de dezembro de 2012 23:45
    segunda-feira, 3 de dezembro de 2012 23:45