VBA - Quebrar texto em colunas


#1

Boa noite! Recebo questionário xls com perguntas e suas alternativas na coluna A, e tentei criar uma macro no VBA para quebrar o texto em colunas. Segue exemplo:

              Coluna A
              P1) Cidade
              [a ] Rio de Janeiro
              [b ] Salvador
              [c ] São Paulo
              [d ] Outras

              P2) Sexo
              [a ] Masculino
              [b ] Feminino

              P3) Ja tinha feito outro curso?
              [a ] Sim (Quais)
              [b ] Não
              [c ] Não Opinou

Eu preciso que toda vez que localizar o texto “P”, o texto seja separado por coluna:

              Coluna A                     Coluna B                Coluna C
              P1) Cidade                  P2) Sexo                 P3) Ja tinha feito outro curso?
              [a ] Rio de Janeiro       [a ] Masculino         [a ] Sim (Quais)
              [b ] Salvador                [b ] Feminino           [b ] Não
              [c ] São Paulo                                              [c ] Não opinou
              [d ] Outras

Tentei através do “IF” do Vba, mas não consegui. Alguém pode ajudar?

Sub SepararTextoColunas()
Dim rng As Range
Dim i As Integer, counter As Integer
Set rng = Range(“A1:A3000”)
i = 1
For counter = 1 To rng.Rows.Count
If rng.Cells(i) = “P” Then
rng.Cells(i).EntireColumn.Split
Else
i = i + 1
End If
Next
End Sub

Obrigado


#2

Fala, @Ramos. Tudo bem?

Fiz uma simulação aqui com o seguinte código:

 Sub Ordenar()

ActiveSheet.Range("A2").Select

Do While ActiveCell.Value2 <> "" Or ActiveCell.Offset(1, 0).Value2 <> ""

    If ActiveCell.Row > 3000 Then
    
        ActiveSheet.Range("A1").Select
        Exit Sub
    
    End If

    If Left(ActiveCell.Value2, 1) = "P" Then
    
        Aux = ActiveCell.Row
        Aux2 = ActiveCell.End(xlDown).Row
        ActiveSheet.Range(Selection, "B" & Aux2).Select
        Selection.Cut
        ActiveSheet.Range("D1").Select
        
        Do While ActiveCell.Value <> ""
        
            ActiveCell.Offset(0, 3).Select
        
        Loop
        
        ActiveSheet.Paste
        ActiveSheet.Range("A" & Aux).End(xlDown).Select
        GoTo continue
    
    End If

    ActiveCell.Offset(1, 0).Select

continue:

Loop

End Sub

Funcionou para a maneira que arrumei os dados na planilha.