Dados repetidos em colunas em uma mesma linha

[Visitante]

Bom dia amigos,

Gostaria de saber se existe solução para o impasse que tenho.

Estou com uma lista com 35mil linhas, onde na coluna A tenho o nome da pessoa, na coluna D o DDD e na coluna E o telefone do mesmo.

Acontece que algumas pessoas possuem 2 ou 3 telefones cadastrados e eu precisava colocar em uma mesma linha segundo a seguinte ideia:

Caso a pessoa só tenha 1 telefone cadastrado na planilha, nada ocorre. Caso tenha 2 telefones, este segundo DDD seria incluído na coluna F e o segundo telefone na coluna G. Caso tenha um 3º telefone, este terceiro DDD seria incluído na coluna H e o terceiro telefone na coluna I.

É possível?

Se sim, como procedo?

Anexa uma imagem com um pequeno exemplo de como vejo a lista e como deveria ficar.

[Visitante]

a) considerei os nomes ordenados, ou de A para Z ou de Z para A

o resultado será colocado pelo código a partir de 'G1'

Instale o código abaixo em um módulo comum, assim:

1. copie o código daqui

2. a partir da planilha em que estão os dados tecle 'Alt+F11' para acessar o editor de VBA

3. no menu do editor >> Inserir >> Módulo

4. cole o código na janela em branco que vai se abrir

5. feito! 'Alt+Q' para retornar para a planilha e testar

para rodar o código:

6. tecle 'Alt+F8' >> selecione a macro 'TranspNumTelef' >> Executar, ou insira um botão na planilha e vincule-o à macro

Sub TranspNumTelef()
 Dim LR As Long, k As Long, x As Long, y As Long
 Dim s As String, v As Variant, m As Long, i As Long
  LR = Cells(Rows.Count, 1).End(xlUp).Row
   For k = 1 To LR
    x = Application.CountIf(Range(Cells(k + 1, 1), _
        Cells(LR, 1)), Cells(k, 1).Value)
     If x > 0 Then
      For y = 1 To x
       s = s & "," & Cells(k + y, 4) & "," & Cells(k + y, 5).Value
      Next y
       v = Split(s, ",")
       Cells(1 + m, 7).Value = Cells(k, 1).Value
       Cells(1 + m, 8).Resize(, 2).Value = Cells(k, 4).Resize(, 2).Value

        For i = LBound(v) + 1 To UBound(v)
         Cells(1 + m, i + 9) = v(i)
        Next i
         k = k + x
         s = ""
     Else:
       Cells(1 + m, 7).Value = Cells(k, 1).Value
       Cells(1 + m, 8).Resize(, 2).Value = Cells(k, 4).Resize(, 2).Value
     End If
     m = m + 1
   Next k
End Sub

[Visitante]

a) considerei os nomes ordenados, ou de A para Z ou de Z para A

o resultado será colocado pelo código a partir de 'G1'

Instale o código abaixo em um módulo comum, assim:

1. copie o código daqui

2. a partir da planilha em que estão os dados tecle 'Alt+F11' para acessar o editor de VBA

3. no menu do editor >> Inserir >> Módulo

4. cole o código na janela em branco que vai se abrir

5. feito! 'Alt+Q' para retornar para a planilha e testar

para rodar o código:

6. tecle 'Alt+F8' >> selecione a macro 'TranspNumTelef' >> Executar, ou insira um botão na planilha e vincule-o à macro

Sub TranspNumTelef()
 Dim LR As Long, k As Long, x As Long, y As Long
 Dim s As String, v As Variant, m As Long, i As Long
  LR = Cells(Rows.Count, 1).End(xlUp).Row
   For k = 1 To LR
    x = Application.CountIf(Range(Cells(k + 1, 1), _
        Cells(LR, 1)), Cells(k, 1).Value)
     If x > 0 Then
      For y = 1 To x
       s = s & "," & Cells(k + y, 4) & "," & Cells(k + y, 5).Value
      Next y
       v = Split(s, ",")
       Cells(1 + m, 7).Value = Cells(k, 1).Value
       Cells(1 + m, 8).Resize(, 2).Value = Cells(k, 4).Resize(, 2).Value

        For i = LBound(v) + 1 To UBound(v)
         Cells(1 + m, i + 9) = v(i)
        Next i
         k = k + x
         s = ""
     Else:
       Cells(1 + m, 7).Value = Cells(k, 1).Value
       Cells(1 + m, 8).Resize(, 2).Value = Cells(k, 4).Resize(, 2).Value
     End If
     m = m + 1
   Next k
End Sub

Osvaldo...

Funcionou perfeitamente a vossa macro.

Muito obrigado pela ajuda!

[Patropi]

Caso o autor do tópico necessite, o mesmo será reaberto, para isso deverá entrar em contato com a moderação solicitando o desbloqueio.