Transformar linhas em colunas, deixando a primeira coluna fixa, copiando para outras linhas

[danisgrala]

Olá galera,

Tenho uma lista com de contatos de e-mails, em formato de linha.

Preciso transformar elas em linhas separadas, mas mantendo a primeira coluna, copiando para todas as linhas a mesma informação.

Podem me socorrer?  coloquei o exemplo abaixo, usando o | como divisor de colunas.

Está assim:

|Agencia 1| joao@gmail.com;maria@gmail.com;pedro@gmail.com;

|Agencia 2| juliana@gmail.com.br;vanessa@gmail.com;

|Agencia 3| fernando@gmail.com;daniel@gmail.com;@daniela@gmail;com;karen@gmail.com

Forma que preciso

|Agencia 1| joao@gmail.com

|Agencia 1| maria@gmail.com

|Agencia 1| pedro@gmail.com

|Agencia 2| juliana@gmail.com

|Agencia 2| vanessa@gmail.com

|Agencia 3| fernando@gmail.com

|Agencia 3| daniel@gmail.com

|Agencia 3| daniela@gmail.com

|Agencia 3| karen@gmail.com

[rlm]

experimente:

experimente:

[code]Sub Separa_Registro()
Dim i As Integer, j As Integer, x As Integer
Dim strSep() As String
j = 2
'Inclui ma nova sheet e nomeia
Sheets.Add
ActiveSheet.Name = "Contato"

With Sheets("Base de Dados")
    For i = 1 To .Range("a" & Rows.Count).End(xlUp).Row
        'Separa os registros utilizando ";" como delimitador
        strSep = Split(.Cells(i, 2), ";")
        'Loop dos registros individuais e grava na planilha criada
        For x = 0 To UBound(strSep)
            If strSep(x) <> "" Then
                Sheets("Contato").Cells(j, 1) = .Cells(i, 1).Value
                Sheets("contato").Cells(j, 2) = strSep(x)
            j = j + 1
            End If
        Next
    Next
End With
End Sub[/code]

 

Editado Agosto 23, 2021 por rlm