Este fórum está sendo desativado

[JCabral]

Boa tarde
Precisava de uma ajuda para fazer um código para separar texto de celulas em varias colunas, assim tenho como dados em celulas o seguinte formato:

1 RAP_AAA NOME1 | TELEFONE Nº1 NOME2 | TELEFONE Nº1 | TELEFONE Nº2 NOME3 | TELEFONE Nº1 | TELEFONE Nº2 | TELEFONE Nº3 NOME4 | TELEFONE Nº1 | TELEFONE Nº2 NOME5 | TELEFONE Nº1 | TELEFONE Nº2

e necessitava que os dados fossem separados da seguinte forma:
idContactos CCC ORDEM USER NOME EMAIL TEL1 TEL2 TEL3
1 RAP_AAA 1 NOME1 TELEFONE Nº1
2 RAP_AAA 2 NOME2 TELEFONE Nº1 TELEFONE Nº2
3 RAP_AAA 3 NOME3 TELEFONE Nº1 TELEFONE Nº2 TELEFONE Nº3
4 RAP_AAA 4 NOME4 TELEFONE Nº1 TELEFONE Nº2
5 RAP_AAA 5 NOME5 TELEFONE Nº1 TELEFONE Nº2

NOTA: A "ORDEM" repete-se sempre para cada CCC e é sempre de 1 a 5 (nº máximo de contatos por cada CCC é cinco)
Tenho sempre um nº de telefone num máximo de 3 telefones por cada NOME
A escrita da separação deve ser efetuada na ABA CONTATOS.
Tenho várias linhas de dados em DADOS, aqui só coloquei 3

No ficheiro anexo exemplifico com mais dados e com os resultados expectáveis.
Obrigado

[osvaldomp]

Salve, Jorge.

Veja se o código abaixo pode ajudar.

Código: Selecionar todos

Sub SeparaContatos()
 Dim cc As Range, i As Long, k As Long, LR As Long, x As Variant
  With Sheets("CONTATOS")
   .Cells.Clear
   .[A2] = 1: .[A2].AutoFill Destination:=.[A2].Resize((Application.CountA(Sheets("DADOS").[A:A]) - 1) * 5), Type:=xlFillSeries
   For Each cc In Sheets("DADOS").Range("B2:B" & Sheets("DADOS").Cells(Rows.Count, 2).End(3).Row)
    LR = .Cells(Rows.Count, 2).End(3).Row
    .Cells(LR + 1, 2).Resize(5) = cc.Value
    .Cells(LR + 1, 3) = 1: .Cells(LR + 1, 3).AutoFill Destination:=.Cells(LR + 1, 3).Resize(5), Type:=xlFillSeries
    For k = 1 To 5
     If cc.Offset(, k).Value = "" Then Exit For
     x = Split(cc.Offset(, k).Value, " | ")
      For i = LBound(x) To UBound(x)
       .Cells(LR + 1, i + 4) = x(i)
      Next i
      LR = LR + 1
     Next k
   Next cc
   .Columns(4).Insert: .Columns(6).Insert
   .[A1:I1] = Array("idContactos", "CCC", "ORDEM", "USER", "NOME", "EMAIL", "TEL1", "TEL2", "TEL3")
   .Rows(1).HorizontalAlignment = xlCenter
  End With
End Sub

[JCabral]

Caro Osvaldo

TOP, muito obrigado mais uma vez!