Remover espaços entre os caracteres na célula, mas somente se o espaço existir entre dois caracteres únicos

Para processar em 10.000 linhas de excel, para remover espaços entre caracteres na célula, mas somente se o espaço existir entre dois caracteres únicos.

P J A JACKSON AND SONS

Deve se tornar

PJA JACKSON AND SONS

mas

JOHNSON AND SMITH

deve permanecer

JOHNSON AND SMITH

Isso pode ser feito usando expressões regulares e um localizar e substituir. Na guia Início, no grupo Edição, clique em Substituir para abrir a caixa de diálogo Localizar e Substituir. Se você não vir a caixa de seleção Usar caracteres curinga, clique em Mais e marque a caixa de seleção.

Encontrar: (<[^\s]>) (<[^\s]>) Substituir: \1\2

Isso corresponderá a todos os espaços entre dois caracteres únicos e, em seguida, os removerá. Espero que isto ajude!

Selecione as células que você deseja processar e execute esta macro:

Sub formatter()
  Dim txt As String, i As Long
  Dim r As Range, txt2 As String

  For Each r In Selection
    txt = r.Text
    If InStr(1, txt, " ") > 0 Then
      ary = Split(txt, " ")
      txt2 = ary(0)
      For i = 1 To UBound(ary)
        If Len(ary(i - 1)) = 1 And Len(ary(i)) = 1 Then
          txt2 = txt2 & ary(i)
        Else
          txt2 = txt2 & " " & ary(i)
        End If
      Next i
      If txt2 <> txt Then
        r.Value = txt2
      End If
    End If
  Next r
End Sub

Aqui está uma solução usando o VBA.

Usar:

pressione Alt + F11 - Copie o código para ThisWorkbook

Você pode executar o código em: MS Excel - View aba - Macros (Hotkey: Alt + F8 )
Ou você pode atribuir um botão a ele.

A macro será aplicada em todas as células usadas por padrão. Se precisar que isso seja modificado, basta deixar um comentário e atualizarei a resposta com as modificações solicitadas.

Sub remove_spaces()

Dim actives As String
Dim c As Range
Dim myStr As String
Dim myArray() As String
Dim wordsc As String
Dim wcount As Integer
Dim newStr As String

actives = ActiveSheet.Name


For Each c In Sheets(actives).UsedRange.Cells

    If c <> "" Then     
        wordsc = c
        wcount = WordCount(wordsc)

        ReDim myArray(wcount)

        myStr = c
        myArray = Split(myStr, " ")
        c = ""
        newStr = myArray(0)

        For i = 1 To wcount - 1
            MsgBox myArray(i)
            If Len(myArray(i - 1)) = 1 And Len(myArray(i)) = 1 Then

                newStr = newStr & myArray(i)

            Else

                newStr = newStr & " " & myArray(i)

            End If

        c = newStr

        Next i

    End If

Next c



End Sub

Function WordCount(fullText As String) As Long
Dim words() As String
Dim firstLetter As String
Dim i As Long

  words = Split(fullText)

  For i = LBound(words) To UBound(words)
    firstLetter = UCase$(Left$(words(i), 1))
    ' if it's alphabetic, +1 word
    If firstLetter Like "[A-Za-z]" Then
      WordCount = WordCount + 1
    End If
  Next i

End Function