Eliminar espacios entre caracteres en la celda, pero solo si el espacio existe entre dos caracteres individuales

Para procesar en 10,000 líneas de Excel, para eliminar espacios entre caracteres en la celda, pero solo si el espacio existe entre dos caracteres individuales.

P J A JACKSON AND SONS

debe convertirse

PJA JACKSON AND SONS

pero

JOHNSON AND SMITH

deberías permanecer

JOHNSON AND SMITH

Esto se puede hacer usando expresiones regulares y buscar y reemplazar. En la pestaña Inicio, en el grupo Edición, haga clic en Reemplazar para abrir el cuadro de diálogo Buscar y reemplazar. Si no ve la casilla de verificación Usar comodines, haga clic en Más y luego seleccione la casilla de verificación.

Buscar: (<[^\s]>) (<[^\s]>) reemplazar: \1\2

Esto coincidirá con todos los espacios entre dos caracteres individuales y luego los eliminará. ¡Espero que esto ayude!

Seleccione las celdas que desea procesar y ejecute 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

Aquí hay una solución usando VBA.

Usar:

Presione Alt+ F11- Copie el código enThisWorkbook

Puede ejecutar el código desde: MS Excel - Viewpestaña - Macros(tecla de acceso rápido: Alt+ F8)
o puede asignarle un botón.

La macro se aplicará en cada celda utilizada de forma predeterminada. Si necesita esta modificación, solo deje un comentario y actualizaré la respuesta con las modificaciones 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