Skip to main content
Para corregir una errata en el código
Origen Enlace
Angel M.
  • 224
  • 3
  • 9
Function ReplaceUpperWordsBy_ReemplazaMayusculasPorSubrayado(strToConvert) As String
    Dim i As Integer
    Dim j As Integer
    Dim strDST As String
    Dim isCaps As Boolean
    
    strToConvert = Replace(strToConvert, ".", " .")
    strToConvert = Replace(strToConvert, ",", " ,")
    strToConvert = Replace(strToConvert, ";", " ;")
    strToConvert = strToConvert + " "
    i = 1
    strDST = ""
    
    While i < Len(strToConvert)
        j = i
        isCaps = True
        While Mid(strToConvert, j, 1) <> " " And j < Len(strToConvert)
            If Mid(strToConvert, j, 1) = LCase(Mid(strToConvert, j, 1)) Then
                isCaps = False
            End If
            j = j + 1
        Wend
        If isCaps And (Mid(strToConvert, j, 1) = " " Or j = Len(strToConvert)) And j - i > 1 Then
            If Mid(strToConvert, j, 1) = " " Then
                strDST = strDST + String(j - i, "_") + " "
            Else
                strDST = strDST + String(j - i + 1, "_")
            End If
        Else
            strDST = strDST + Mid(strToConvert, i, j - i + 1)
        End If
        i = j + 1
        
    Wend
    strDST = Replace(strDST, " .", ".")
    strDST = Replace(strDST, " ,", ",")
    strDST = Replace(strDST, " ;", ";")
    strDST = Mid(strDST, 1, Len(strDST) - 1)
    
    ReplaceUpperWordsBy_ =ReemplazaMayusculasPorSubrayado= strDST
End Function
Function ReplaceUpperWordsBy_(strToConvert) As String
    Dim i As Integer
    Dim j As Integer
    Dim strDST As String
    Dim isCaps As Boolean
    
    strToConvert = Replace(strToConvert, ".", " .")
    strToConvert = Replace(strToConvert, ",", " ,")
    strToConvert = Replace(strToConvert, ";", " ;")
    strToConvert = strToConvert + " "
    i = 1
    strDST = ""
    
    While i < Len(strToConvert)
        j = i
        isCaps = True
        While Mid(strToConvert, j, 1) <> " " And j < Len(strToConvert)
            If Mid(strToConvert, j, 1) = LCase(Mid(strToConvert, j, 1)) Then
                isCaps = False
            End If
            j = j + 1
        Wend
        If isCaps And (Mid(strToConvert, j, 1) = " " Or j = Len(strToConvert)) And j - i > 1 Then
            If Mid(strToConvert, j, 1) = " " Then
                strDST = strDST + String(j - i, "_") + " "
            Else
                strDST = strDST + String(j - i + 1, "_")
            End If
        Else
            strDST = strDST + Mid(strToConvert, i, j - i + 1)
        End If
        i = j + 1
        
    Wend
    strDST = Replace(strDST, " .", ".")
    strDST = Replace(strDST, " ,", ",")
    strDST = Replace(strDST, " ;", ";")
    strDST = Mid(strDST, 1, Len(strDST) - 1)
    
    ReplaceUpperWordsBy_ = strDST
End Function
Function ReemplazaMayusculasPorSubrayado(strToConvert) As String
    Dim i As Integer
    Dim j As Integer
    Dim strDST As String
    Dim isCaps As Boolean
    
    strToConvert = Replace(strToConvert, ".", " .")
    strToConvert = Replace(strToConvert, ",", " ,")
    strToConvert = Replace(strToConvert, ";", " ;")
    strToConvert = strToConvert + " "
    i = 1
    strDST = ""
    
    While i < Len(strToConvert)
        j = i
        isCaps = True
        While Mid(strToConvert, j, 1) <> " " And j < Len(strToConvert)
            If Mid(strToConvert, j, 1) = LCase(Mid(strToConvert, j, 1)) Then
                isCaps = False
            End If
            j = j + 1
        Wend
        If isCaps And (Mid(strToConvert, j, 1) = " " Or j = Len(strToConvert)) And j - i > 1 Then
            If Mid(strToConvert, j, 1) = " " Then
                strDST = strDST + String(j - i, "_") + " "
            Else
                strDST = strDST + String(j - i + 1, "_")
            End If
        Else
            strDST = strDST + Mid(strToConvert, i, j - i + 1)
        End If
        i = j + 1
        
    Wend
    strDST = Replace(strDST, " .", ".")
    strDST = Replace(strDST, " ,", ",")
    strDST = Replace(strDST, " ;", ";")
    strDST = Mid(strDST, 1, Len(strDST) - 1)
    
    ReemplazaMayusculasPorSubrayado= strDST
End Function
Origen Enlace
Angel M.
  • 224
  • 3
  • 9

He visto que la primera solución propuesta no contempla las palabras que empiezan por mayúsculas o la palabra I y hace el reemplazo por el carácter _. Así que he encontrado una solución que sí que funciona bien en todos los casos que he probado, considerando que las palabras pueden estar separadas por espacios, comas, puntos o punto y coma:

Function ReplaceUpperWordsBy_(strToConvert) As String
    Dim i As Integer
    Dim j As Integer
    Dim strDST As String
    Dim isCaps As Boolean
    
    strToConvert = Replace(strToConvert, ".", " .")
    strToConvert = Replace(strToConvert, ",", " ,")
    strToConvert = Replace(strToConvert, ";", " ;")
    strToConvert = strToConvert + " "
    i = 1
    strDST = ""
    
    While i < Len(strToConvert)
        j = i
        isCaps = True
        While Mid(strToConvert, j, 1) <> " " And j < Len(strToConvert)
            If Mid(strToConvert, j, 1) = LCase(Mid(strToConvert, j, 1)) Then
                isCaps = False
            End If
            j = j + 1
        Wend
        If isCaps And (Mid(strToConvert, j, 1) = " " Or j = Len(strToConvert)) And j - i > 1 Then
            If Mid(strToConvert, j, 1) = " " Then
                strDST = strDST + String(j - i, "_") + " "
            Else
                strDST = strDST + String(j - i + 1, "_")
            End If
        Else
            strDST = strDST + Mid(strToConvert, i, j - i + 1)
        End If
        i = j + 1
        
    Wend
    strDST = Replace(strDST, " .", ".")
    strDST = Replace(strDST, " ,", ",")
    strDST = Replace(strDST, " ;", ";")
    strDST = Mid(strDST, 1, Len(strDST) - 1)
    
    ReplaceUpperWordsBy_ = strDST
End Function

Esta función habría que llamarla para todas las celdas de tu Base de Datos en Excel y habría que guardar el resultado en la celda contigua. Te pongo un ejemplo de como se podría llamar pero tendrías que parametrizar la función para inicializar las variables intFila e intColumna con los valores donde empieza tu rango y dejar la columna de al lado vacía porque la macro te la rellenará:

Public Sub ReemplazaTodo()
    Dim intFila As Integer
    Dim intColumna As Integer
    intFila = 1
    intColumna = 1
    While Len(Cells(intFila, intColumna).Value) > 0
        Cells(intFila, intColumna + 1).Value = ReemplazaMayusculasPorSubrayado(Cells(intFila, intColumna).Value)
        intFila = intFila + 1
        DoEvents
    Wend
    
End Sub