0
153
VistasCompara dos celdas y muestra los cambios en otra celda
Estoy tratando de comparar dos oraciones en diferentes celdas y mostrar la diferencia en rojo.
Mi código está comparando la posición de cada letra. Cuando encuentra una diferencia, la muestra en rojo, lo cual está bien.
El problema es que si se cambia una palabra por otra con diferente número de letras, el resto de la frase también aparece en rojo.
Como ejemplo:
En esta imagen puedes ver que después de encontrar una palabra, el resto de las palabras también aparecen como diferentes aunque sean iguales.
Este es el código que estoy usando actualmente:
Sub Compare() For i = 1 To Len(ActiveSheet.Range("F1").Value) If (ActiveSheet.Range("F1").Characters(i, 1).Text <> ActiveSheet.Range("G1").Characters(i, 1).Text) Then ActiveSheet.Range("F1").Characters(i, 1).Font.Color = RGB(255, 0, 0) End If Next i End SubAdemás, este código solo funciona en la celda seleccionada. ¿Cómo puedo hacer que funcione con toda la columna (F y G)?
3 Respuestas
Responde la pregunta0
Comparar palabras en dos celdas
- Apenas probado.
Option Explicit Sub CompareTwoCellsTEST() Dim ws As Worksheet: Set ws = ActiveSheet ' improve! CompareTwoCells ws.Range("A1"), ws.Range("B1") End Sub Sub CompareTwoCells(ByVal ChangeCell As Range, ByVal CompareCell As Range) Dim Change() As String: Change = Split(CStr(ChangeCell.Value)) Dim Compare() As String: Compare = Split(CStr(CompareCell.Value)) Dim n As Long Dim Pos As Long Dim ch As Long Dim ErrNum As Long Dim sChange As String Dim sCompare As String For n = 0 To UBound(Change) sChange = Change(n) On Error Resume Next sCompare = Compare(n) On Error GoTo 0 If Len(sCompare) > 0 Then If StrComp(sChange, sCompare, vbBinaryCompare) <> 0 Then For ch = 1 To Len(sChange) If ErrNum = 0 Then On Error Resume Next If Mid(sChange, ch, 1) <> Mid(sCompare, ch, 1) Then ChangeCell.Characters(Pos + ch, 1) _ .Font.Color = vbRed End If ErrNum = Err.Number On Error GoTo 0 Else ChangeCell.Characters(Pos + ch, 1).Font.Color = vbRed End If Next ch ErrNum = 0 End If sCompare = vbNullString End If Pos = Pos + Len(sChange) + 1 Next n End Sub0
Como se sugiere en los comentarios, la función Split aquí es tu amiga:
prueba este código:
Sub test() Dim ControlActual As Variant Dim ControlAntiguo As Variant Dim i As Long Dim j As Long Dim k As Long Dim AcumuladoControlActual As Long Dim AcumuladoControlAntiguo As Long i = 4 'starting row of data Do Until Range("A" & i).Value = "" ControlActual = Split(Range("A" & i).Value, " ") ControlAntiguo = Split(Range("B" & i).Value, " ") AcumuladoControlActual = 0 AcumuladoControlAntiguo = 0 For j = LBound(ControlActual) To UBound(ControlActual) Step 1 k = 1 Do Until k > Len(ControlActual(j)) And k > Len(ControlAntiguo(j)) If Mid(ControlActual(j), k, 1) <> Mid(ControlAntiguo(j), k, 1) Then If k <= Len(ControlActual(j)) Then Range("A" & i).Characters(AcumuladoControlActual + k, 1).Font.Color = RGB(255, 0, 0) If k <= Len(ControlAntiguo(j)) Then Range("B" & i).Characters(AcumuladoControlAntiguo + k, 1).Font.Color = RGB(255, 0, 0) End If k = k + 1 Loop AcumuladoControlActual = AcumuladoControlActual + Len(ControlActual(j)) + 1 AcumuladoControlAntiguo = AcumuladoControlAntiguo + Len(ControlAntiguo(j)) + 1 Next j i = i + 1 Loop End Sub 
De todos modos, esto funcionará correctamente solo si ambas frases tienen la misma cantidad de palabras y en el mismo orden esperado. Frases totalmente diferentes pueden producir resultados extraños.
0
Este código más o menos hace el truco. Muestra dónde las palabras son iguales encadenando su color al verde. De esta manera puedes diferenciar entre las palabras que son iguales (color verde) y las que son diferentes (color estándar).
Espero que esto ayude a cualquiera que haya tenido el mismo problema que el mío.
Sub find_differences() Dim xStr() As String Dim i As Long Dim x As Long, y As Long With ActiveSheet For i = 3 To .Cells(.Rows.Count, "G").End(xlUp).Row xStr = Split(.Cells(i, "G").Value, " ") xStrH = Split(.Cells(i, "H").Value, " ") With .Cells(i, "H") .Font.ColorIndex = 1 For x = LBound(xStr()) To UBound(xStr()) For y = 1 To Len(.Text) If Mid(.Text, y, Len(xStr(x))) = xStr(x) Then .Characters(y, Len(xStr(x))).Font.ColorIndex = 4 End If Next y Next x End With Next i End With End Sub