Excel Organização de texto dentro de uma mesma célula

[MateusAC3]

Boa noite, anexei 2 tabelas de exemplo onde eu gostaria de organizar através de macro as "LOCAÇÕES" da coluna "B" seguindo alguns critérios:

 

*  As iniciais "AL...", "DCA...", "DCS...", "SPA...", "RAC..." e "BPOINT" são prefixos ou palavras que não variam

 

- Locações repetidas dentro da mesma célula deverão ser unificadas (ou apagada a duplicata)

- Locações que iniciam com "9" seguido de vários números deverão ser apagadas

- No final se sobrar "/" deverá ser apagada

- Caso estejam presentes, as locações que deverão ser movidas para o final da célula serão essas na respectiva ordem: 

BPOINT (último)

ALQ... (penúltimo)

ALT... (antepenúltimo)

RAC... (pré-antepenúltimo)

SPA... (antes do pré-antepenúltimo)

 

- O restante das locações deverá ser movido para o começo da célula, em ordem alfabética de acordo com a penúltima letra

Ex.:

 

Desorganizadas:

BPOINT/ALF01F1/ALH02D1/BPOINT/ALQ12A1/ALH02D1/

SPA05B/BPOINT/DCA036C1/DCA036A2/DCA036E1/ALQ12E1/ALT27D3

 

Organizadas:

ALH02D1/ALF01F1/ALQ12A1/BPOINT

DCA036A2/DCA036C1/DCA036E1/SPA05B/ALT27D3/ALQ12E1/BPOINT

 

(Eu pintei as letras apenas pra melhor visualização dos critérios aplicados)

 

Agradeço muito desde já quem puder me ajudar nesse desafio.

 

 

Pasta1.xlsx

[MateusAC3]

Poderiam cancelar esse tópico por favor? Achei uma alternativa mais fácil sem precisar da macro 

[MateusAC3]

Retire o q eu disse kkk, não deu certo, preciso da macro infelizmente 

[OreiaG]

Em 05/12/2023 às 19:20, MateusAC3 disse:

(Eu pintei as letras apenas pra melhor visualização dos critérios aplicados)

É preferível colocar os resultados na própria planilha.

 

Os resultados serão colocados na coluna C.

As colunas D:G serão utilizadas como colunas auxiliares.

 

Sub OrganizaTextos()
 Dim X, r As Range, rng As Range, r1 As Range, r2 As Range, k As Long, v As Long
  Application.ScreenUpdating = False
  [C:G] = ""
  For Each rng In Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
   X = Split(rng.Value, "/")
   [D1].Resize(UBound(X) + 1).Value = Application.Transpose(X)
   Range("D1:D" & Cells(Rows.Count, 4).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
   For v = 1 To Cells(Rows.Count, 4).End(3).Row
    If Left(Cells(v, 4), 1) = 9 Then
     Cells(v, 4).Clear: GoTo jump
    Else
     Select Case Left(Cells(v, 4), 3)
      Case "BPO": k = 5
      Case "ALQ": k = 4
      Case "ALT": k = 3
      Case "RAC": k = 2
      Case "SPA": k = 1
      Case Else: k = 0
     End Select
    End If
    If k = 0 Then
     Cells(Rows.Count, 6).End(3)(2, 2) = Mid(Cells(v, 4), Len(Cells(v, 4)) - 1, 1)
     Cells(v, 4).Cut Cells(Rows.Count, 6).End(3)(2)
    Else
     Cells(v, 4).Cut Cells(Rows.Count, 4).End(3)(2)
     Cells(Rows.Count, 4).End(3)(1, 2) = k
    End If
jump:
   Next v
   Range("D:G").SpecialCells(4).Delete
   Range("D1:E" & Cells(Rows.Count, 4).End(3).Row).Sort Key1:=[E1], Key2:=[D1], Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
   Range("F1:G" & Cells(Rows.Count, 6).End(3).Row).Sort Key1:=[G1], Key2:=[F1], Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
   Set r1 = Range("F1:F" & Cells(Rows.Count, 6).End(3).Row)
   Set r2 = Range("D1:D" & Cells(Rows.Count, 4).End(3).Row)
   rng.Offset(, 1).Value = WorksheetFunction.TextJoin("/", True, r1) & "/" & WorksheetFunction.TextJoin("/", True, r2)
   [D:G] = ""
  Next rng
End Sub

 

[MateusAC3]

Tem um erro acontecendo: caso aconteça de ter apenas 1 locação na célula, teoricamente teria q ser dispensado todo esse processo nela

[OreiaG]

1 hora atrás, MateusAC3 disse:

Tem um erro acontecendo: caso aconteça de ter apenas 1 locação na célula, teoricamente teria q ser dispensado todo esse processo nela

1. agradeça a toda tentativa de ajuda recebida

2. informe se o código funcionou corretamente na planilha anexada por você

3. "caso aconteça de ter apenas 1 locação na célula," existe na planilha anexada algum caso como esse? em qual célula está?

4. anexe nova planilha com dados representativos e com os correspondentes resultados desejados

 

[MateusAC3]

Desculpe por não agir de acordo com as regras de etiqueta e do forum, agradeço imensamente pela ajuda que eu recebi e na mensagem anterior não tive intenção nenhuma de reclamar ou criticar, apenas apresentei uma questão da qual eu não havia previsto antes, só que eu não soube repassar da maneira correta, sou péssimo de comunicação e não tenho muita experiência em forum, perdão mesmo, vou tentar não repetir esses erros que eu cometi.

 

Hoje de tardezinha eu posto a planilha com essa opção representada

 

Obrigado 

[MateusAC3]

Boa noite, anexei outra planilha, agora com o formato mais parecido com o projeto original e com todas as possibilidades, incluindo os resultados desejados.

Obrigado

Pasta1.xlsx

[OreiaG]

Olá, @MateusAC3.

 

Fiz os ajustes no código conforme o seu último arquivo, que está claro e completo.

 

1. ao executar o código a planilha DESORGANIZADA deverá ser a planilha ativa

3. os resultados serão colocados na coluna K e as colunas L:O serão utilizadas como colunas auxiliares.

4. há duas divergências entre o resultado do código e o seu resultado desejado:

  a) linha 11 - no seu resultado estão invertidas entre si as posições de ALQ e SPA, conforme os seus critérios na planilha  SEQUÊNCIA DESEJADA

  b) linha 14 - os conteúdos são iguais, porém as posições dos 4 códigos ALT aparecerão diferentes do seu resultado; se essas posições forem importantes então você precisa fornecer critérios adicionais para o posicionamento de códigos que se repetem

 

 

Sub OrganizaTextosV2()
 Dim X, r As Range, rng As Range, r1 As Range, r2 As Range, k As Long, v As Long
  Application.ScreenUpdating = False
  [K:O] = ""
  For Each rng In Range("G2:G" & Cells(Rows.Count, 7).End(3).Row)
   X = Split(rng.Value, "/")
   [L1].Resize(UBound(X) + 1).Value = Application.Transpose(X)
   If [L2] = "" Then rng.Offset(, 4).Value = [L1]: GoTo jump2
   Range("L1:L" & Cells(Rows.Count, 12).End(3).Row).RemoveDuplicates Columns:=1, Header:=xlNo
   For v = 1 To Cells(Rows.Count, 12).End(3).Row
    If Left(Cells(v, 12), 1) = 9 Then
     Cells(v, 12).Clear: GoTo jump1
    Else
     Select Case Left(Cells(v, 12), 3)
      Case "BPO": k = 8
      Case "ALQ": k = 7
      Case "ALT": k = 6
      Case "RAC": k = 5
      Case "SPA": k = 4
      Case "LPP": k = 3
      Case "LPJ": k = 2
      Case "LPA": k = 1
      Case Else: k = 0
     End Select
    End If
    If k = 0 Then
     Cells(Rows.Count, 14).End(3)(2, 2) = Mid(Cells(v, 12), Len(Cells(v, 12)) - 1, 1)
     Cells(v, 12).Cut Cells(Rows.Count, 14).End(3)(2)
    Else
     Cells(Rows.Count, 12).End(3)(2, 2) = k
     Cells(v, 12).Cut Cells(Rows.Count, 12).End(3)(2)
    End If
jump1:
   Next v
   Range("L:O").SpecialCells(4).Delete
   Range("L1:M" & Cells(Rows.Count, 12).End(3).Row).Sort Key1:=[M1], Key2:=[L1], Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
   Range("N1:O" & Cells(Rows.Count, 14).End(3).Row).Sort Key1:=[O1], Key2:=[N1], Order1:=xlAscending, Header:=xlNo, DataOption1:=xlSortTextAsNumbers
   If [N1] <> "" Then Set r1 = Range("N1:N" & Cells(Rows.Count, 14).End(3).Row)
   If [L1] <> "" Then Set r2 = Range("L1:L" & Cells(Rows.Count, 12).End(3).Row)
   If r1 Is Nothing Then
    rng.Offset(, 4).Value = WorksheetFunction.TextJoin("/", True, r2)
   ElseIf r2 Is Nothing Then
    rng.Offset(, 4).Value = WorksheetFunction.TextJoin("/", True, r1)
   Else: rng.Offset(, 4).Value = WorksheetFunction.TextJoin("/", True, r1) & "/" & WorksheetFunction.TextJoin("/", True, r2)
   End If
jump2:
   [L:O] = "": Set r1 = Nothing: Set r2 = Nothing
  Next rng
End Sub

 

[Midori]

@MateusAC3 Se o seu excel for o 365 e quiser tentar com fórmulas,

 

 

 

Na linha 10 o meu ficou diferente com o prefixo SPA antes de ALQ.

[MateusAC3]

Boa noite, muito obrigado a todos pela ajuda, funcionou perfeitamente

 

7 horas atrás, OreiaG disse:

a) linha 11 - no seu resultado estão invertidas entre si as posições de ALQ e SPA, conforme os seus critérios na planilha

Realmente, cometi um erro ali, acho que é bem por isso que essa macro vai ser muito útil, pra evitar esse tipo de erro.

 

 

7 horas atrás, OreiaG disse:

b) linha 14 - os conteúdos são iguais, porém as posições dos 4 códigos ALT aparecerão diferentes do seu resultado; se essas posições forem importantes então você precisa fornecer critérios adicionais para o posicionamento de códigos que se repetem

Não tem problema, a ordem alfabética da penúltima letra só é importante pros códigos do começo da célula.

 

Obrigado!