Filtro e Transpor

Question

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

---

[e-mail]

Answer 1

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

Answer 2

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.

---

[e-mail]

Answer 3

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

Answer 4

Perfeito.

Muito obrigado pela oportunidade de aprendizado.

---

[e-mail]