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

[MColucci]

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.

ITEM		LOCAÇÃO
10763380	ALT48D1/ALT48D2/DCA001F1/DCA001E1/ALT48D3/DCA001E3/DCA001F3/
15396678	ALT19A3/DCS018E1/DCS018D1/DCS018C1/DCS018E2/ALT62G1
15432208	SPA15A/ALQ08A2/DCS028B1/DCS028B2/ALT41A3
15432210	DCA028E1/ALT43G1/ALT42D1/ALT42A1/ALT37G3
15396704	93300001/BPOINT/ALT44A3/DCA034B1/SPA03A/DCA034A1/BPOINT/DCA034A2
10763376	SPA05B/BPOINT/DCA036C1/DCA036A2/DCA036E1/ALQ12E1/ALT27D3


ITEM		LOCAÇÃO
10788155	ALD21A2/BPOINT/RAC2SVC1
12092080	ALQ01B2/BPOINT/ALE01F4/
12065932	BPOINT/ALF01F1/ALH02D1/BPOINT/ALQ12A1/ALH02D1/
PPN00698	90056896/SPA01A/ALF01A2
15344639	RAC2SVC1/ALF01J1/ALB08E3
10810293	SPA01B/ALF03A2/
10863947	ALG04C4/ALG04C4/
12198556	90057421/ALL01J4/SPA08B/
15470987	AST29D1/ALQ12A1/SPA04B

 

[MColucci]

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

[MColucci]

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

[MColucci]

Conseguiram uma solução pra mim, obrigado

Considerando que os códigos estejam na coluna "G", ficaria assim:

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
  [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