Excel Separar textos em linhas

[Muca Costa]

Gostaria de separar cada linha de texto em uma linha. Conforme demonstrado no arquivo em anexo...

Teste.xlsx

[Visitante]

Sub DesmembrarLinhasDeCélulas()
 Dim r As Range, c As Range, i As Long, h
  If [H3] <> "" Then Range("H3:M" & Cells(Rows.Count, 8).End(3).Row).Value = ""
  For Each r In Range("A3:A" & Cells(Rows.Count, 1).End(3).Row)
   If Application.CountA(r.Offset(, 1).Resize(, 5)) > 0 Then
    For Each c In r.Offset(, 1).Resize(, 5)
     If c.Value <> "" Then
      i = Len(c.Value) - Len(Replace(c.Text, Chr(10), ""))
      If i > 0 Then
       h = Split(c.Value, Chr(10))
       If i + 1 > Application.CountIf([H:H], r.Value) Then
        Cells(Rows.Count, 8).End(3)(2).Resize(i + 1 - Application.CountIf([H:H], r.Value)).Value = r.Value
       End If
       Cells(Rows.Count, 8).End(3)(-i + 1, c.Column).Resize(i + 1).Value = Application.Transpose(h)
      Else: If Application.CountIf([H:H], r.Value) = 0 Then Cells(Rows.Count, 8).End(3)(2) = r.Value
       Cells(Rows.Count, 8).End(3)(-i + 1, c.Column) = c.Value
      End If
     End If
    Next c
   Else: Cells(Rows.Count, 8).End(3)(2) = r.Value
   End If
  Next r
End Sub

obs.
1. o resultado desejado que você colocou na planilha apresenta inconsistência dos dados no intervalo A14:E18
2. copie o intervalo A2:F2 e cole em H2, assim o código acima colocará o resultado a partir de H3
3. antes de testar o código acima limpe o intervalo A8:F21

[Muca Costa]

Tudo certo. Obrigado osvaldomp.

[Patropi]

@Muca Costa

 

Como a resposta do Osvaldo foi útil, você se esqueceu de clicar em Curtir e de marcar o tópico como Resolvido, conforme instrução no link da minha assinatura.

 

[]s