Este fórum está sendo desativado

[Domingsp]

Olá, nessa planilha gostaria de intercalar caracteres mediante o que é encontrado na coluna B:

Se nas células de B houver 1, o 1 fica sem alteração.
Para todo AB, antes virá um "C".
Para todo 4, antes virão dois "X".
Para todo 5, antes virão três "S".
Para todo WS, antes virão quatro "E".

A ordem dos caracteres de B não é alterada, apenas são intercalados outros caracteres.

Fiz uma macro que não está resolvendo. Não sei como incrementar, passando para as próximas linhas, percorrendo a coluna B.

Escrevi na coluna F como deve ficar, só como explicação, mas o ideal é que o resultado saia na própria coluna B.
Coloquei a execução por meio de um ScrollBar, executando linha por linha, mas se for executado num botão, de uma só vez, é até melhor.
Desde já, obrigado.

INTERCALAMENTO.xlsm

[osvaldomp]

Experimente:

Código: Selecionar todos

Sub InsereCaracteres()
 Dim rngB As Range, str As String
  For Each rngB In Range("B2:B" & Cells(Rows.Count, 2).End(3).Row)
   Select Case rngB.Value
    Case "AB": str = "C"
    Case 4: str = "XX"
    Case 5: str = "SSS"
    Case "WS": str = "EEEE"
   End Select
   If str <> "" Then rngB.Value = str & rngB.Value: str = ""
  Next rngB
End Sub

[Domingsp]

osvaldomp, Obrigado pela rapidez em reponder

Mas se observar a coluna F, que é onde coloquei como deve ficar o resultado desejado, os caracteres iniciais foram deslocados e os caracteres(C, XX, SSS, EEEE...) são inseridos entre eles. Não seria da forma apresentada.
Expliquei mal ao escrever que a "ordem dos caracteres não é alterada". Na verdade, eles precisam ser deslocados para a inserção dos outros.

[osvaldomp]

Foi vacilo meu. Entendi errado. Peço desculpas.
Experimente este abaixo no lugar do anterior.

Código: Selecionar todos

Sub InserePreencheCélulas()
 Dim x As Long, k As Long, str As String
  x = 2
  Do While Cells(x, 2) <> ""
   Select Case Cells(x, 2)
    Case "AB": k = 1: str = "C"
    Case 4: k = 2: str = "X"
    Case 5: k = 3: str = "S"
    Case "WS": k = 4: str = "E"
   End Select
   If k > 0 Then
    Cells(x, 2).Resize(k).Insert Shift:=xlDown
    Cells(x, 2).Resize(k) = str
    x = x + k: k = 0
   End If
   x = x + 1
  Loop
End Sub

[Domingsp]

Agora sim! Ficou show. Obrigado.