Este fórum está sendo desativado

[Rabatini]

Olá pessoal,

Estou precisando de uma ajuda.

Tenho um texto grande que está em uma linha inteira
exemplo

A1 tem esse texto = 546456465645645554146578941456[BEGIN]Brincadeira legal[END]001454541245645478954152346578674589[BEGIN]Vamos brincar amiguinhos?[END]

Fiz uma macro que ele extrai o Texto a partir do [BEGIN] e para de extrair quando lê o [END]
gostaria de fazer que ele continue fazendo isso na celula a1, até ela não encontrar mais texto.

Ficaria assim. [BEGIN]Brincadeira legal[END][BEGIN] Vamos brincar amiguinhos?[END] ETC... até o texto acabar.

Meu código está fazendo isso apenas até o primeiro [END]

Código: Selecionar todos

Private Sub CommandButton1_Click()
Dim pos_first As Integer
Dim pos_second As Integer
Dim result_string As String

Dim main_text As String
Dim search_text As String

main_text = Worksheets("planilha4").Cells(1.1).Value
search_text = "[BEGIN]"
pos_first = InStr(1, main_text, search_text)

main_text = Worksheets("planilha4").Cells(1.1).Value
search_text = "[END]"
pos_second = InStr(pos_first + 1, main_text, search_text)

result_string = Mid(main_text, pos_first + 0, pos_second - pos_first - 0)

Worksheets("planilha4").Cells(1.5).Value = result_string

End Sub

Agradeço a atenção!!!

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub ExtraiParteTexto()
 Dim K As Long, x As Long, m As Long
  For K = 1 To UBound(Split([A1], "[BEGIN]"))
   x = InStr(K + m, [A1], "[BEGIN]")
   m = InStr(K + m, [A1], "[END]")
   Cells(Rows.Count, 5).End(3)(2) = Mid([A1], x + 7, m - x - 7)
  Next K
End Sub

#
curiosidade: este comando que você postou Cells(1.1) funciona aí sem erro? A sintaxe correta é Cells(1,1), com vírgula e não com ponto separando os argumentos.

[mucascosta]

Pode ser assim também:

Código: Selecionar todos

Sub Extrair()
 Dim LR As Long, k As Long
 LR = Cells(Rows.Count, "A").End(xlUp).Row
 Application.ScreenUpdating = False
  For k = LR To 1 Step -1
   If Cells(k, "A").Value <> "" Then
    c1 = Cells(k, "A").Replace("0", "", xlPart)
    c2 = Cells(k, "A").Replace("1", "", xlPart)
    c3 = Cells(k, "A").Replace("2", "", xlPart)
    c4 = Cells(k, "A").Replace("3", "", xlPart)
    c5 = Cells(k, "A").Replace("4", "", xlPart)
    c6 = Cells(k, "A").Replace("5", "", xlPart)
    c7 = Cells(k, "A").Replace("6", "", xlPart)
    c8 = Cells(k, "A").Replace("7", "", xlPart)
    c9 = Cells(k, "A").Replace("8", "", xlPart)
    c10 = Cells(k, "A").Replace("9", "", xlPart)
    
   End If
  Next k
  Application.ScreenUpdating = True
      Range("A1").Select
End Sub

[Rabatini]

Boa noite, obrigado pela respostas pessoal.

Ambos os códigos não deram certo.

O primeiro, dá um erro aqui Cells(Rows.Count, 5).End(3)(2) = Mid([A1], x + 7, m - x - 7)
Invalid argument.

O segundo Ele apaga todos os numeros e deixa os <>, a ideia é deixar oq tem escrito entre BEGIN e END mesmo sendo numeros ou chars.

Código: Selecionar todos

Private Sub CommandButton1_Click()
Dim pos_first As Integer
Dim pos_second As Integer
Dim result_string As String

Dim main_text As String
Dim search_text As String

  
main_text = Worksheets("sheet1").Cells(1, 1).Value
search_text = "[BEGIN]"
pos_first = InStr(1, main_text, search_text)

main_text = Worksheets("sheet1").Cells(1, 1).Value
search_text = "[END]"
pos_second = InStr(pos_first + 1, main_text, search_text)

result_string = Mid(main_text, pos_first + 0, pos_second - pos_first + 5)
Worksheets("sheet1").Cells(3, 1).Value = result_string
End Sub

Esse meu código funciona exatamente como eu quero, porém ele busca primeiro begin para no end. teria fazer ele ir em tudo até não achar mais begin.
segue exemplo https://drive.google.com/file/d/14qrMk1 ... sp=sharing
Need help!!!

Se der prair separando por linha seria ótimo, mas só de fazer o loop desse código já me ajudaria muito.

abraços e obrigado pela atenção.

[osvaldomp]

Veja o arquivo anexado, com o código que passei.

[Rabatini]

Boa noite Osvaldo,

Seu código funcionou certinho, ai fui o porque não tinha funcionado anteriormente

Já sei porque deu o erro.
Porque tem vezes que tem um END sem BEGIN.
Segue anexo a planilha com o erro de argumento.

No meio dos textos Tem END sem BEgin, eles deve ser ignorados, só ler mesmo os Begins.
Se achar begin extrai texto até end e para, ai continua, ignorando os END sem BEGIN pelo caminho.

Desculpe o incomodo ai.

E agradeço muito a ajuda.

[osvaldomp]

Este código abaixo funciona para os dois exemplos que você forneceu até agora.
Se houver mais variações que o código não reconheça então informe TODAS as variações de uma vez.

Código: Selecionar todos

Sub ExtraiParteTexto()
 Dim K As Long, x As Long, m As Long
rstt:
  For K = 1 To UBound(Split([A1], "[BEGIN]"))
   x = InStr(K + m, [A1], "[BEGIN]")
   m = InStr(K + m, [A1], "[END]")
   If x < m Then
    Cells(Rows.Count, 5).End(3)(2) = Mid([A1], x + 7, m - x - 7)
   Else:   GoTo rstt
   End If
  Next K
End Sub

[Rabatini]

Este código abaixo funciona para os dois exemplos que você forneceu até agora.
Se houver mais variações que o código não reconheça então informe TODAS as variações de uma vez.

Código: Selecionar todos

Sub ExtraiParteTexto()
 Dim K As Long, x As Long, m As Long
rstt:
  For K = 1 To UBound(Split([A1], "[BEGIN]"))
   x = InStr(K + m, [A1], "[BEGIN]")
   m = InStr(K + m, [A1], "[END]")
   If x < m Then
    Cells(Rows.Count, 5).End(3)(2) = Mid([A1], x + 7, m - x - 7)
   Else:   GoTo rstt
   End If
  Next K
End Sub

Muito obrigado osvaldo.
Deu certinho.
Assim que chegar em casa, vou te mandar a planilha, na verdade eu precisava sim de uma ajuda em outras variações.
aí te explico melhor, se puder me ajudar.
Agradeço muito sua ajuda.