Comparar 2 hojas de Excel [VBA]
Resuelto
binos359
Mensajes publicados
2
Estado
Miembro
-
binos359 Mensajes publicados 2 Estado Miembro -
binos359 Mensajes publicados 2 Estado Miembro -
Hola,
Me permito solicitar tu ayuda porque me bloqueo con la programación VBA para un proyecto.
Lo que tengo:
2 hojas de Excel con listas, el número de identificación es único.
Lo que quiero:
- comparar la hoja 2 con la hoja 1
- si hay correspondencia se elimina la fila
- si el objeto de la hoja2 no se encuentra en hoja1 se copia la fila en otra página
- si algo de la hoja 1 no está en la hoja 2 se elimina la fila también
¿Cómo modificar este código para lograrlo?
(por ahora el que tiene elimina únicamente duplicados presentes en la misma página y por lo tanto mantiene la información de la hoja 1 que no está presente en la hoja 2)
Muchas gracias :)
Sub duplicados ()
elección = InputBox("Elige la acción que te interesa:" & Chr(10) & Chr(10) & "1. Colorear los duplicados (colorear la celda)" & Chr(10) & "2. Colorear los duplicados (colorear toda la fila)" & Chr(10) & "3. Borrar los duplicados (dejando la fila en blanco)" & Chr(10) & "4. Eliminar los duplicados (fila completa)" & Chr(10) & "5. Eliminar filas en blanco" & Chr(10) & Chr(10) & "Ingresa el número de la acción y haz clic en Aceptar:")
If elegir = "" Then Exit Sub
elección2 = ""
If elección = 1 Or elección = 2 Or elección = 3 Or elección = 4 Then elección2 = InputBox("Ingresa la letra de la columna donde deben buscarse los duplicados : »)
If elección = 5 Then elección2 = InputBox("Ingresa la letra de la columna a tener en cuenta (si la celda de esta columna está vacía, la fila será eliminada):")
If elección2 = "" Then Exit Sub
Application.ScreenUpdating = False
test = Timer
der_fila = Range(choix2 & "65000").End(xlUp).Row
Dim tab_cells()
ReDim tab_cells(der_fila - 1)
For ligne = 1 To der_fila
tab_cells(ligne - 1) = Range(choix2 & ligne)
Next
nb = 0
If choix = 4 Or choix = 5 Then compteur = 0
For ligne = 1 To der_fila
contenu = tab_cells(ligne - 1)
If (choix = 1 Or choix = 2) And contenu <> "" Then 'Colorear duplicados
For i = 1 To der_fila
If contenu = tab_cells(i - 1) And ligne <> i Then 'Si duplicado
nb = nb + 1
If choix = 1 Then
Range(choix2 & ligne).Interior.ColorIndex = 3
Else
Range(ligne & ":" & ligne).Interior.ColorIndex = 3
End If
Exit For
End If
Next
End If
If (choix = 3 Ou choix = 4) And ligne > 1 And contenu <> "" Then 'Borrar/eliminar duplicados
For i = 1 To ligne - 1
If contenu = tab_cells(i - 1) Then 'Si duplicado
nb = nb + 1
If choix = 3 Then
Range(ligne & ":" & ligne).ClearContents
Else
Range(ligne + compteur & ":" & ligne + compteur).Delete
compteur = compteur - 1
End If
Exit For
End If
Next
End If
If choix = 5 And contenu = "" Then 'Líneas en blanco
Range(ligne + compteur & ":" & ligne + compteur).Delete
compteur = compteur - 1
nb = nb + 1
End If
Next
res_test = Format(Timer - test, "0" & Application.DecimalSeparator & "000")
Application.ScreenUpdating = True
If nb = 0 And choix = 5 Then
dd = MsgBox("A ninguna fila en blanco encontrada ...", 64, "Resultado")
ElseIf nb = 0 Then
dd = MsgBox("Ningún duplicado encontrado en la columna " & UCase(choix2) & " ...", 64, "Resultado")
ElseIf choix = 5 Then
dd = MsgBox(nb & " filas eliminadas (en " & res_test & " segundos)", 64, "Resultado")
ElseIf choix = 4 Then
dd = MsgBox(nb & " duplicados eliminados (en " & res_test & " segundos)", 64, "Resultado")
ElseIf choix = 3 Then
dd = MsgBox(nb & " duplicados borrados (en " & res_test & " segundos)", 64, "Resultado") Else
dd = MsgBox(nb & " duplicados pasados en rojo (en " & res_test & " segundos)", 64, "Resultado")
End If
End Sub
Me permito solicitar tu ayuda porque me bloqueo con la programación VBA para un proyecto.
Lo que tengo:
2 hojas de Excel con listas, el número de identificación es único.
Lo que quiero:
- comparar la hoja 2 con la hoja 1
- si hay correspondencia se elimina la fila
- si el objeto de la hoja2 no se encuentra en hoja1 se copia la fila en otra página
- si algo de la hoja 1 no está en la hoja 2 se elimina la fila también
¿Cómo modificar este código para lograrlo?
(por ahora el que tiene elimina únicamente duplicados presentes en la misma página y por lo tanto mantiene la información de la hoja 1 que no está presente en la hoja 2)
Muchas gracias :)
Sub duplicados ()
elección = InputBox("Elige la acción que te interesa:" & Chr(10) & Chr(10) & "1. Colorear los duplicados (colorear la celda)" & Chr(10) & "2. Colorear los duplicados (colorear toda la fila)" & Chr(10) & "3. Borrar los duplicados (dejando la fila en blanco)" & Chr(10) & "4. Eliminar los duplicados (fila completa)" & Chr(10) & "5. Eliminar filas en blanco" & Chr(10) & Chr(10) & "Ingresa el número de la acción y haz clic en Aceptar:")
If elegir = "" Then Exit Sub
elección2 = ""
If elección = 1 Or elección = 2 Or elección = 3 Or elección = 4 Then elección2 = InputBox("Ingresa la letra de la columna donde deben buscarse los duplicados : »)
If elección = 5 Then elección2 = InputBox("Ingresa la letra de la columna a tener en cuenta (si la celda de esta columna está vacía, la fila será eliminada):")
If elección2 = "" Then Exit Sub
Application.ScreenUpdating = False
test = Timer
der_fila = Range(choix2 & "65000").End(xlUp).Row
Dim tab_cells()
ReDim tab_cells(der_fila - 1)
For ligne = 1 To der_fila
tab_cells(ligne - 1) = Range(choix2 & ligne)
Next
nb = 0
If choix = 4 Or choix = 5 Then compteur = 0
For ligne = 1 To der_fila
contenu = tab_cells(ligne - 1)
If (choix = 1 Or choix = 2) And contenu <> "" Then 'Colorear duplicados
For i = 1 To der_fila
If contenu = tab_cells(i - 1) And ligne <> i Then 'Si duplicado
nb = nb + 1
If choix = 1 Then
Range(choix2 & ligne).Interior.ColorIndex = 3
Else
Range(ligne & ":" & ligne).Interior.ColorIndex = 3
End If
Exit For
End If
Next
End If
If (choix = 3 Ou choix = 4) And ligne > 1 And contenu <> "" Then 'Borrar/eliminar duplicados
For i = 1 To ligne - 1
If contenu = tab_cells(i - 1) Then 'Si duplicado
nb = nb + 1
If choix = 3 Then
Range(ligne & ":" & ligne).ClearContents
Else
Range(ligne + compteur & ":" & ligne + compteur).Delete
compteur = compteur - 1
End If
Exit For
End If
Next
End If
If choix = 5 And contenu = "" Then 'Líneas en blanco
Range(ligne + compteur & ":" & ligne + compteur).Delete
compteur = compteur - 1
nb = nb + 1
End If
Next
res_test = Format(Timer - test, "0" & Application.DecimalSeparator & "000")
Application.ScreenUpdating = True
If nb = 0 And choix = 5 Then
dd = MsgBox("A ninguna fila en blanco encontrada ...", 64, "Resultado")
ElseIf nb = 0 Then
dd = MsgBox("Ningún duplicado encontrado en la columna " & UCase(choix2) & " ...", 64, "Resultado")
ElseIf choix = 5 Then
dd = MsgBox(nb & " filas eliminadas (en " & res_test & " segundos)", 64, "Resultado")
ElseIf choix = 4 Then
dd = MsgBox(nb & " duplicados eliminados (en " & res_test & " segundos)", 64, "Resultado")
ElseIf choix = 3 Then
dd = MsgBox(nb & " duplicados borrados (en " & res_test & " segundos)", 64, "Resultado") Else
dd = MsgBox(nb & " duplicados pasados en rojo (en " & res_test & " segundos)", 64, "Resultado")
End If
End Sub
2 respuestas
Hola,
El código que encontraste en la red compara 2 columnas ubicadas en la misma hoja
Aquí tienes un ejemplo con 2 columnas ubicadas en 2 hojas para adaptar:
Colocar en un UserForm 5 botones con este código:
Puedes adaptar inputsBox con los códigos que están en los botones haciendo macros
--
Le Pivert
El código que encontraste en la red compara 2 columnas ubicadas en la misma hoja
Aquí tienes un ejemplo con 2 columnas ubicadas en 2 hojas para adaptar:
Colocar en un UserForm 5 botones con este código:
Option Explicit Dim der_ligne, cel1, cel2, li 'colorea duplicados Private Sub CommandButton1_Click() der_ligne = Range("A" & "65000").End(xlUp).Row For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne) For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne) If cel1 = cel2 Then li = li + 1 cel1.Interior.ColorIndex = 3 cel2.Interior.ColorIndex = 3 End If Next Next End Sub 'restablece color inicial Private Sub CommandButton2_Click() der_ligne = Range("A" & "65000").End(xlUp).Row Sheets("Feuil1").Range("A1:A" & der_ligne).Interior.ColorIndex = xlNone Sheets("Feuil2").Range("A1:A" & der_ligne).Interior.ColorIndex = xlNone End Sub 'borrar contenido la fila duplicada hoja2 Private Sub CommandButton3_Click() der_ligne = Range("A" & "65000").End(xlUp).Row For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne) For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne) If cel1 = cel2 Then li = li + 1 cel2.ClearContents End If Next Next End Sub 'copiar fila sin duplicados en feuil3 Private Sub CommandButton4_Click() der_ligne = Range("A" & "65000").End(xlUp).Row For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne) For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne) If cel1 = cel2 Then li = li + 1 cel1.Interior.ColorIndex = 3 End If Next Next li = 0 For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne) If cel1.Interior.ColorIndex = xlNone Then li = li + 1 Sheets("Feuil3").Select Range("A" & li).Value = cel1 End If Next Sheets("Feuil1").Range("A1:A" & der_ligne).Interior.ColorIndex = xlNone End Sub 'eliminar la fila duplicada hoja2 Private Sub CommandButton5_Click() der_ligne = Range("A" & "65000").End(xlUp).Row For Each cel1 In Sheets("Feuil1").Range("A1:A" & der_ligne) For Each cel2 In Sheets("Feuil2").Range("A1:A" & der_ligne) If cel1 = cel2 Then li = li + 1 cel2.Delete End If Next Next End Sub Private Sub UserForm_Initialize() CommandButton1.Caption = "Colorear duplicados" CommandButton2.Caption = "Restablecer colores" CommandButton3.Caption = "Borrar filas" CommandButton4.Caption = "Copiar filas" CommandButton5.Caption = "Eliminar filas" End Sub Puedes adaptar inputsBox con los códigos que están en los botones haciendo macros
--
Le Pivert