Hola Excel Facilito. Me podrían apoyar con una duda talvez básica. Manejo listas de precios y productos, donde en ocasiones en una sola celda tengo que poner el modelo de 1 moto, y en ocasiones de 80 motos y quiero que todas las celdas queden del mismo tamaño. Hay alguna manera de hacer una barra de desplazamiento para una sola celda, para que los que consulten puedan ver la información de una manera más sencilla. GRACIAS!!!!
Gracias... por esos videos... amigos.. tego un caso que quiero solucionar... quiero hacer una macro donde me compare de la hoja1 dos columnas y busque las coincidencias con la hoja dos y segun las coincidencias me copie en hoja tres las filas completas que coincidan. las celdas que no coincidan queden en rojo... sera que si es posible o me estoy complicando la vida ... Ayudaaaa :(
Public A, B, C As Worksheet Public PrimerError As Boolean Public x, y, z As Long Public letra As String Public salir As Boolean Public Gestionaerror As Integer Public segundos1 As Single Public segundos2 As Single Sub Comparar() Application.ScreenUpdating = False Application.DisplayAlerts = False segundos1 = Timer() Dim cantidad As Long Dim cantidad2 As Long 'UserForm1.Show 'strArchivo = Application.GetOpenFilename salir = False letra = ThisWorkbook.Sheets("Parametros").Range("Letra") Sheets("Diferencias").Select Cells.Delete Shift:=xlUp Call Filtros Sheets("Version 1").Select cantidad = Range("b1048576").End(xlUp).Row Call Espacios Call Ordenar Sheets("Version 2").Select cantidad2 = Range("b1048576").End(xlUp).Row Call Espacios Call Ordenar Call Validar_LLaves Gestionaerror: If (salir = True) Then Exit Sub End If Call CompararHojas Sheets("Diferencias").Select If (Range("a2").Value "" Or Range("b2").Value "") Then MsgBox ("Revisar Archivo, contiene informacion diferente") Else MsgBox ("No hay registros diferentes") Application.StatusBar = False End If End Sub '------------------------------------------------------------------------------------------ Function CompararHojas() Sheets("Version 1").Select cantidad = Range("b1048576").End(xlUp).Row On Error Resume Next Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") C.Cells.ClearContents 'A.Cells.Interior.Color = xlNone 'B.Cells.Interior.Color = xlNone C.Cells.Interior.Color = xlNone A.Rows(1).Copy C.Rows(1) C.Activate z = 1 j = 1 k = 1 For x = 1 To A.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row PrimerError = False For y = 1 To A.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ultima2 = Range("b1048576").End(xlUp).Row Porcentaje = (conteo * 100) / cantidad Application.StatusBar = "Porcentaje Procesado: " & Round(Porcentaje, 0) & " %" & " Tiempo de ejecucion: " & Round((segundos2 - segundos1) / 60, 1) & " Minutos" If A.Cells(x, y) B.Cells(x, y) Then If PrimerError = False Then PrimerError = True z = z + 1 k = k + 1 B.Rows(x).Copy C.Rows(z) End If 'C.Cells(z, y).Font.Color = vbRed C.Cells(z, y).Font.Bold = True C.Cells(z, y).Interior.ColorIndex = 3 bandera = True ElseIf (bandera True) Then bandera = False End If Next y z = z + 1 j = j + 1 If (bandera True) Then If (k > 0) Then k = k - 1 C.Rows(ultima2).Delete End If A.Rows(j).Copy C.Rows(ultima2) z = z - 1 Else k = k + 1 A.Rows(j).Copy C.Rows(z) bandera = False End If conteo = conteo + 1 segundos2 = Timer() Next x A.Rows(1).Copy C.Rows(1).Insert Shift:=xlDown 'C.Cells.Interior.Color = 3 End Function '' me sirve para quitar los espacios al comienzo y al final de todas las columnas Function Espacios() With ActiveSheet.UsedRange .Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))") End With End Function '------------------------------------------------------------------------------------------ '' me sirve para ordenar en orden ascendente por la clave primaria Function Ordenar() On Error Resume Next Range(letra).Sort Key1:=Range(letra), Order1:=xlAscending, Header:=xlYes End Function '------------------------------------------------------------------------------------------ Function Validar_LLaves() Dim Celda As Range Sheets("Version 1").Select If (cantidad cantidad2) Then NumeroColumna = Range(letra).Column Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") A.Columns(NumeroColumna).Copy C.Columns(1) B.Columns(NumeroColumna).Copy C.Columns(2) cantidad = Range("b1048576").End(xlUp).Row Sheets("Diferencias").Select Range("a1") = "Version 1" Range("b1") = "Version 2" Range("C1") = "INCONSISTENCIAS" Range("C2").Select ActiveCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""CORRECTO"",""INCORRECTO"")" Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad) On Error Resume Next Selection.AutoFilter Field:=3, Criteria1:="INCORRECTO" MsgBox ("no concuerda el el dato de la columna primary key " & letra & " en ambos archivos") Sheets("Diferencias").Select salir = True Exit Function Else NumeroColumna = Range(letra).Column Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") A.Columns(NumeroColumna).Copy C.Columns(1) B.Columns(NumeroColumna).Copy C.Columns(2) cantidad = Range("b1048576").End(xlUp).Row Sheets("Diferencias").Select Range("C1") = "DIFERENCIAS" Range("C2").Select Range("a1") = "Version 1" Range("b1") = "Version 2" cantidad = Range("b1048576").End(xlUp).Row Range("C2").Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-2],C[-1],1,0),""NO ENCONTRADO"")" Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad) On Error Resume Next Selection.AutoFilter Field:=3, Criteria1:="NO ENCONTRADO" Range("c:c").Select cantidad = Worksheets("Diferencias").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 If cantidad > 0 Then salir = True MsgBox (" Los registros de Version 1 (columna A) no fueron encontrados en Version 2 (columna B) la llave primaria debe estar en ambos archivos para poder comparar") Exit Function End If C.Cells.ClearContents C.Cells.ClearContents Sheets("Diferencias").Select End If End Function '------------------------------------------------------------------------------------------ '' me sirve para quitar todos los filtros de las hojas Function Filtros() For Each Hojas In ActiveWorkbook.Sheets If Hojas.AutoFilterMode Then Hoja.Range("A1").AutoFilter End If Next Hojas End Function
Public A, B, C As Worksheet Public PrimerError As Boolean Public x, y, z As Long Public letra As String Public salir As Boolean Public Gestionaerror As Integer Public segundos1 As Single Public segundos2 As Single Sub Comparar() Application.ScreenUpdating = False Application.DisplayAlerts = False segundos1 = Timer() Dim cantidad As Long Dim cantidad2 As Long 'UserForm1.Show 'strArchivo = Application.GetOpenFilename salir = False letra = ThisWorkbook.Sheets("Parametros").Range("Letra") Sheets("Diferencias").Select Cells.Delete Shift:=xlUp Call Filtros Sheets("Version 1").Select cantidad = Range("b1048576").End(xlUp).Row Call Espacios Call Ordenar Sheets("Version 2").Select cantidad2 = Range("b1048576").End(xlUp).Row Call Espacios Call Ordenar Call Validar_LLaves Gestionaerror: If (salir = True) Then Exit Sub End If Call CompararHojas Sheets("Diferencias").Select If (Range("a2").Value "" Or Range("b2").Value "") Then MsgBox ("Revisar Archivo, contiene informacion diferente") Else MsgBox ("No hay registros diferentes") Application.StatusBar = False End If End Sub '------------------------------------------------------------------------------------------ Function CompararHojas() Sheets("Version 1").Select cantidad = Range("b1048576").End(xlUp).Row On Error Resume Next Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") C.Cells.ClearContents 'A.Cells.Interior.Color = xlNone 'B.Cells.Interior.Color = xlNone C.Cells.Interior.Color = xlNone A.Rows(1).Copy C.Rows(1) C.Activate z = 1 j = 1 k = 1 For x = 1 To A.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row PrimerError = False For y = 1 To A.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ultima2 = Range("b1048576").End(xlUp).Row Porcentaje = (conteo * 100) / cantidad Application.StatusBar = "Porcentaje Procesado: " & Round(Porcentaje, 0) & " %" & " Tiempo de ejecucion: " & Round((segundos2 - segundos1) / 60, 1) & " Minutos" If A.Cells(x, y) B.Cells(x, y) Then If PrimerError = False Then PrimerError = True z = z + 1 k = k + 1 B.Rows(x).Copy C.Rows(z) End If 'C.Cells(z, y).Font.Color = vbRed C.Cells(z, y).Font.Bold = True C.Cells(z, y).Interior.ColorIndex = 3 bandera = True ElseIf (bandera True) Then bandera = False End If Next y z = z + 1 j = j + 1 If (bandera True) Then If (k > 0) Then k = k - 1 C.Rows(ultima2).Delete End If A.Rows(j).Copy C.Rows(ultima2) z = z - 1 Else k = k + 1 A.Rows(j).Copy C.Rows(z) bandera = False End If conteo = conteo + 1 segundos2 = Timer() Next x A.Rows(1).Copy C.Rows(1).Insert Shift:=xlDown 'C.Cells.Interior.Color = 3 End Function '' me sirve para quitar los espacios al comienzo y al final de todas las columnas Function Espacios() With ActiveSheet.UsedRange .Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))") End With End Function '------------------------------------------------------------------------------------------ '' me sirve para ordenar en orden ascendente por la clave primaria Function Ordenar() On Error Resume Next Range(letra).Sort Key1:=Range(letra), Order1:=xlAscending, Header:=xlYes End Function '------------------------------------------------------------------------------------------ Function Validar_LLaves() Dim Celda As Range Sheets("Version 1").Select If (cantidad cantidad2) Then NumeroColumna = Range(letra).Column Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") A.Columns(NumeroColumna).Copy C.Columns(1) B.Columns(NumeroColumna).Copy C.Columns(2) cantidad = Range("b1048576").End(xlUp).Row Sheets("Diferencias").Select Range("a1") = "Version 1" Range("b1") = "Version 2" Range("C1") = "INCONSISTENCIAS" Range("C2").Select ActiveCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""CORRECTO"",""INCORRECTO"")" Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad) On Error Resume Next Selection.AutoFilter Field:=3, Criteria1:="INCORRECTO" MsgBox ("no concuerda el el dato de la columna primary key " & letra & " en ambos archivos") Sheets("Diferencias").Select salir = True Exit Function Else NumeroColumna = Range(letra).Column Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") A.Columns(NumeroColumna).Copy C.Columns(1) B.Columns(NumeroColumna).Copy C.Columns(2) cantidad = Range("b1048576").End(xlUp).Row Sheets("Diferencias").Select Range("C1") = "DIFERENCIAS" Range("C2").Select Range("a1") = "Version 1" Range("b1") = "Version 2" cantidad = Range("b1048576").End(xlUp).Row Range("C2").Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-2],C[-1],1,0),""NO ENCONTRADO"")" Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad) On Error Resume Next Selection.AutoFilter Field:=3, Criteria1:="NO ENCONTRADO" Range("c:c").Select cantidad = Worksheets("Diferencias").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 If cantidad > 0 Then salir = True MsgBox (" Los registros de Version 1 (columna A) no fueron encontrados en Version 2 (columna B) la llave primaria debe estar en ambos archivos para poder comparar") Exit Function End If C.Cells.ClearContents C.Cells.ClearContents Sheets("Diferencias").Select End If End Function '------------------------------------------------------------------------------------------ '' me sirve para quitar todos los filtros de las hojas Function Filtros() For Each Hojas In ActiveWorkbook.Sheets If Hojas.AutoFilterMode Then Hoja.Range("A1").AutoFilter End If Next Hojas End Function
Public A, B, C As Worksheet Public PrimerError As Boolean Public x, y, z As Long Public letra As String Public salir As Boolean Public Gestionaerror As Integer Public segundos1 As Single Public segundos2 As Single Sub Comparar() Application.ScreenUpdating = False Application.DisplayAlerts = False segundos1 = Timer() Dim cantidad As Long Dim cantidad2 As Long 'UserForm1.Show 'strArchivo = Application.GetOpenFilename salir = False letra = ThisWorkbook.Sheets("Parametros").Range("Letra") Sheets("Diferencias").Select Cells.Delete Shift:=xlUp Call Filtros Sheets("Version 1").Select cantidad = Range("b1048576").End(xlUp).Row Call Espacios Call Ordenar Sheets("Version 2").Select cantidad2 = Range("b1048576").End(xlUp).Row Call Espacios Call Ordenar Call Validar_LLaves Gestionaerror: If (salir = True) Then Exit Sub End If Call CompararHojas Sheets("Diferencias").Select If (Range("a2").Value "" Or Range("b2").Value "") Then MsgBox ("Revisar Archivo, contiene informacion diferente") Else MsgBox ("No hay registros diferentes") Application.StatusBar = False End If End Sub '------------------------------------------------------------------------------------------ Function CompararHojas() Sheets("Version 1").Select cantidad = Range("b1048576").End(xlUp).Row On Error Resume Next Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") C.Cells.ClearContents 'A.Cells.Interior.Color = xlNone 'B.Cells.Interior.Color = xlNone C.Cells.Interior.Color = xlNone A.Rows(1).Copy C.Rows(1) C.Activate z = 1 j = 1 k = 1 For x = 1 To A.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row PrimerError = False For y = 1 To A.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column ultima2 = Range("b1048576").End(xlUp).Row Porcentaje = (conteo * 100) / cantidad Application.StatusBar = "Porcentaje Procesado: " & Round(Porcentaje, 0) & " %" & " Tiempo de ejecucion: " & Round((segundos2 - segundos1) / 60, 1) & " Minutos"
If A.Cells(x, y) B.Cells(x, y) Then If PrimerError = False Then PrimerError = True z = z + 1 k = k + 1 B.Rows(x).Copy C.Rows(z) End If 'C.Cells(z, y).Font.Color = vbRed C.Cells(z, y).Font.Bold = True C.Cells(z, y).Interior.ColorIndex = 3 bandera = True ElseIf (bandera True) Then bandera = False End If Next y z = z + 1 j = j + 1
If (bandera True) Then If (k > 0) Then k = k - 1 C.Rows(ultima2).Delete End If A.Rows(j).Copy C.Rows(ultima2) z = z - 1 Else k = k + 1 A.Rows(j).Copy C.Rows(z) bandera = False End If conteo = conteo + 1 segundos2 = Timer() Next x A.Rows(1).Copy C.Rows(1).Insert Shift:=xlDown 'C.Cells.Interior.Color = 3 End Function '' me sirve para quitar los espacios al comienzo y al final de todas las columnas Function Espacios() With ActiveSheet.UsedRange .Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))") End With End Function '------------------------------------------------------------------------------------------ '' me sirve para ordenar en orden ascendente por la clave primaria Function Ordenar() On Error Resume Next Range(letra).Sort Key1:=Range(letra), Order1:=xlAscending, Header:=xlYes End Function '------------------------------------------------------------------------------------------ Function Validar_LLaves() Dim Celda As Range Sheets("Version 1").Select If (cantidad cantidad2) Then NumeroColumna = Range(letra).Column Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") A.Columns(NumeroColumna).Copy C.Columns(1) B.Columns(NumeroColumna).Copy C.Columns(2) cantidad = Range("b1048576").End(xlUp).Row Sheets("Diferencias").Select Range("a1") = "Version 1" Range("b1") = "Version 2" Range("C1") = "INCONSISTENCIAS" Range("C2").Select ActiveCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""CORRECTO"",""INCORRECTO"")" Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad) On Error Resume Next Selection.AutoFilter Field:=3, Criteria1:="INCORRECTO" MsgBox ("no concuerda el el dato de la columna primary key " & letra & " en ambos archivos") Sheets("Diferencias").Select salir = True Exit Function Else NumeroColumna = Range(letra).Column Set A = ThisWorkbook.Sheets("Version 1") Set B = ThisWorkbook.Sheets("Version 2") Set C = ThisWorkbook.Sheets("Diferencias") A.Columns(NumeroColumna).Copy C.Columns(1) B.Columns(NumeroColumna).Copy C.Columns(2) cantidad = Range("b1048576").End(xlUp).Row Sheets("Diferencias").Select Range("C1") = "DIFERENCIAS" Range("C2").Select Range("a1") = "Version 1" Range("b1") = "Version 2" cantidad = Range("b1048576").End(xlUp).Row Range("C2").Select ActiveCell.FormulaR1C1 = _ "=IFERROR(VLOOKUP(RC[-2],C[-1],1,0),""NO ENCONTRADO"")" Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad) On Error Resume Next Selection.AutoFilter Field:=3, Criteria1:="NO ENCONTRADO" Range("c:c").Select cantidad = Worksheets("Diferencias").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 If cantidad > 0 Then
salir = True MsgBox (" Los registros de Version 1 (columna A) no fueron encontrados en Version 2 (columna B) la llave primaria debe estar en ambos archivos para poder comparar") Exit Function End If C.Cells.ClearContents C.Cells.ClearContents Sheets("Diferencias").Select End If End Function '------------------------------------------------------------------------------------------ '' me sirve para quitar todos los filtros de las hojas Function Filtros() For Each Hojas In ActiveWorkbook.Sheets If Hojas.AutoFilterMode Then Hoja.Range("A1").AutoFilter End If Next Hojas End Function
Hola Excel Facilito. Me podrían apoyar con una duda talvez básica. Manejo listas de precios y productos, donde en ocasiones en una sola celda tengo que poner el modelo de 1 moto, y en ocasiones de 80 motos y quiero que todas las celdas queden del mismo tamaño. Hay alguna manera de hacer una barra de desplazamiento para una sola celda, para que los que consulten puedan ver la información de una manera más sencilla. GRACIAS!!!!
Hola , aún necesitas ayuda ?
@@robincampo3344 SI PORFAVOR
Gracias... por esos videos... amigos.. tego un caso que quiero solucionar... quiero hacer una macro donde me compare de la hoja1 dos columnas y busque las coincidencias con la hoja dos y segun las coincidencias me copie en hoja tres las filas completas que coincidan. las celdas que no coincidan queden en rojo... sera que si es posible o me estoy complicando la vida ... Ayudaaaa :(
Public A, B, C As Worksheet
Public PrimerError As Boolean
Public x, y, z As Long
Public letra As String
Public salir As Boolean
Public Gestionaerror As Integer
Public segundos1 As Single
Public segundos2 As Single
Sub Comparar()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
segundos1 = Timer()
Dim cantidad As Long
Dim cantidad2 As Long
'UserForm1.Show
'strArchivo = Application.GetOpenFilename
salir = False
letra = ThisWorkbook.Sheets("Parametros").Range("Letra")
Sheets("Diferencias").Select
Cells.Delete Shift:=xlUp
Call Filtros
Sheets("Version 1").Select
cantidad = Range("b1048576").End(xlUp).Row
Call Espacios
Call Ordenar
Sheets("Version 2").Select
cantidad2 = Range("b1048576").End(xlUp).Row
Call Espacios
Call Ordenar
Call Validar_LLaves
Gestionaerror:
If (salir = True) Then
Exit Sub
End If
Call CompararHojas
Sheets("Diferencias").Select
If (Range("a2").Value "" Or Range("b2").Value "") Then
MsgBox ("Revisar Archivo, contiene informacion diferente")
Else
MsgBox ("No hay registros diferentes")
Application.StatusBar = False
End If
End Sub
'------------------------------------------------------------------------------------------
Function CompararHojas()
Sheets("Version 1").Select
cantidad = Range("b1048576").End(xlUp).Row
On Error Resume Next
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
C.Cells.ClearContents
'A.Cells.Interior.Color = xlNone
'B.Cells.Interior.Color = xlNone
C.Cells.Interior.Color = xlNone
A.Rows(1).Copy C.Rows(1)
C.Activate
z = 1
j = 1
k = 1
For x = 1 To A.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
PrimerError = False
For y = 1 To A.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ultima2 = Range("b1048576").End(xlUp).Row
Porcentaje = (conteo * 100) / cantidad
Application.StatusBar = "Porcentaje Procesado: " & Round(Porcentaje, 0) & " %" & " Tiempo de ejecucion: " & Round((segundos2 - segundos1) / 60, 1) & " Minutos"
If A.Cells(x, y) B.Cells(x, y) Then
If PrimerError = False Then
PrimerError = True
z = z + 1
k = k + 1
B.Rows(x).Copy C.Rows(z)
End If
'C.Cells(z, y).Font.Color = vbRed
C.Cells(z, y).Font.Bold = True
C.Cells(z, y).Interior.ColorIndex = 3
bandera = True
ElseIf (bandera True) Then
bandera = False
End If
Next y
z = z + 1
j = j + 1
If (bandera True) Then
If (k > 0) Then
k = k - 1
C.Rows(ultima2).Delete
End If
A.Rows(j).Copy C.Rows(ultima2)
z = z - 1
Else
k = k + 1
A.Rows(j).Copy C.Rows(z)
bandera = False
End If
conteo = conteo + 1
segundos2 = Timer()
Next x
A.Rows(1).Copy
C.Rows(1).Insert Shift:=xlDown
'C.Cells.Interior.Color = 3
End Function
'' me sirve para quitar los espacios al comienzo y al final de todas las columnas
Function Espacios()
With ActiveSheet.UsedRange
.Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")
End With
End Function
'------------------------------------------------------------------------------------------
'' me sirve para ordenar en orden ascendente por la clave primaria
Function Ordenar()
On Error Resume Next
Range(letra).Sort Key1:=Range(letra), Order1:=xlAscending, Header:=xlYes
End Function
'------------------------------------------------------------------------------------------
Function Validar_LLaves()
Dim Celda As Range
Sheets("Version 1").Select
If (cantidad cantidad2) Then
NumeroColumna = Range(letra).Column
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
A.Columns(NumeroColumna).Copy C.Columns(1)
B.Columns(NumeroColumna).Copy C.Columns(2)
cantidad = Range("b1048576").End(xlUp).Row
Sheets("Diferencias").Select
Range("a1") = "Version 1"
Range("b1") = "Version 2"
Range("C1") = "INCONSISTENCIAS"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""CORRECTO"",""INCORRECTO"")"
Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad)
On Error Resume Next
Selection.AutoFilter Field:=3, Criteria1:="INCORRECTO"
MsgBox ("no concuerda el el dato de la columna primary key " & letra & " en ambos archivos")
Sheets("Diferencias").Select
salir = True
Exit Function
Else
NumeroColumna = Range(letra).Column
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
A.Columns(NumeroColumna).Copy C.Columns(1)
B.Columns(NumeroColumna).Copy C.Columns(2)
cantidad = Range("b1048576").End(xlUp).Row
Sheets("Diferencias").Select
Range("C1") = "DIFERENCIAS"
Range("C2").Select
Range("a1") = "Version 1"
Range("b1") = "Version 2"
cantidad = Range("b1048576").End(xlUp).Row
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-2],C[-1],1,0),""NO ENCONTRADO"")"
Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad)
On Error Resume Next
Selection.AutoFilter Field:=3, Criteria1:="NO ENCONTRADO"
Range("c:c").Select
cantidad = Worksheets("Diferencias").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If cantidad > 0 Then
salir = True
MsgBox (" Los registros de Version 1 (columna A) no fueron encontrados en Version 2 (columna B) la llave primaria debe estar en ambos archivos para poder comparar")
Exit Function
End If
C.Cells.ClearContents
C.Cells.ClearContents
Sheets("Diferencias").Select
End If
End Function
'------------------------------------------------------------------------------------------
'' me sirve para quitar todos los filtros de las hojas
Function Filtros()
For Each Hojas In ActiveWorkbook.Sheets
If Hojas.AutoFilterMode Then
Hoja.Range("A1").AutoFilter
End If
Next Hojas
End Function
No esta el código jeje, buen canal.
Public A, B, C As Worksheet
Public PrimerError As Boolean
Public x, y, z As Long
Public letra As String
Public salir As Boolean
Public Gestionaerror As Integer
Public segundos1 As Single
Public segundos2 As Single
Sub Comparar()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
segundos1 = Timer()
Dim cantidad As Long
Dim cantidad2 As Long
'UserForm1.Show
'strArchivo = Application.GetOpenFilename
salir = False
letra = ThisWorkbook.Sheets("Parametros").Range("Letra")
Sheets("Diferencias").Select
Cells.Delete Shift:=xlUp
Call Filtros
Sheets("Version 1").Select
cantidad = Range("b1048576").End(xlUp).Row
Call Espacios
Call Ordenar
Sheets("Version 2").Select
cantidad2 = Range("b1048576").End(xlUp).Row
Call Espacios
Call Ordenar
Call Validar_LLaves
Gestionaerror:
If (salir = True) Then
Exit Sub
End If
Call CompararHojas
Sheets("Diferencias").Select
If (Range("a2").Value "" Or Range("b2").Value "") Then
MsgBox ("Revisar Archivo, contiene informacion diferente")
Else
MsgBox ("No hay registros diferentes")
Application.StatusBar = False
End If
End Sub
'------------------------------------------------------------------------------------------
Function CompararHojas()
Sheets("Version 1").Select
cantidad = Range("b1048576").End(xlUp).Row
On Error Resume Next
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
C.Cells.ClearContents
'A.Cells.Interior.Color = xlNone
'B.Cells.Interior.Color = xlNone
C.Cells.Interior.Color = xlNone
A.Rows(1).Copy C.Rows(1)
C.Activate
z = 1
j = 1
k = 1
For x = 1 To A.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
PrimerError = False
For y = 1 To A.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ultima2 = Range("b1048576").End(xlUp).Row
Porcentaje = (conteo * 100) / cantidad
Application.StatusBar = "Porcentaje Procesado: " & Round(Porcentaje, 0) & " %" & " Tiempo de ejecucion: " & Round((segundos2 - segundos1) / 60, 1) & " Minutos"
If A.Cells(x, y) B.Cells(x, y) Then
If PrimerError = False Then
PrimerError = True
z = z + 1
k = k + 1
B.Rows(x).Copy C.Rows(z)
End If
'C.Cells(z, y).Font.Color = vbRed
C.Cells(z, y).Font.Bold = True
C.Cells(z, y).Interior.ColorIndex = 3
bandera = True
ElseIf (bandera True) Then
bandera = False
End If
Next y
z = z + 1
j = j + 1
If (bandera True) Then
If (k > 0) Then
k = k - 1
C.Rows(ultima2).Delete
End If
A.Rows(j).Copy C.Rows(ultima2)
z = z - 1
Else
k = k + 1
A.Rows(j).Copy C.Rows(z)
bandera = False
End If
conteo = conteo + 1
segundos2 = Timer()
Next x
A.Rows(1).Copy
C.Rows(1).Insert Shift:=xlDown
'C.Cells.Interior.Color = 3
End Function
'' me sirve para quitar los espacios al comienzo y al final de todas las columnas
Function Espacios()
With ActiveSheet.UsedRange
.Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")
End With
End Function
'------------------------------------------------------------------------------------------
'' me sirve para ordenar en orden ascendente por la clave primaria
Function Ordenar()
On Error Resume Next
Range(letra).Sort Key1:=Range(letra), Order1:=xlAscending, Header:=xlYes
End Function
'------------------------------------------------------------------------------------------
Function Validar_LLaves()
Dim Celda As Range
Sheets("Version 1").Select
If (cantidad cantidad2) Then
NumeroColumna = Range(letra).Column
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
A.Columns(NumeroColumna).Copy C.Columns(1)
B.Columns(NumeroColumna).Copy C.Columns(2)
cantidad = Range("b1048576").End(xlUp).Row
Sheets("Diferencias").Select
Range("a1") = "Version 1"
Range("b1") = "Version 2"
Range("C1") = "INCONSISTENCIAS"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""CORRECTO"",""INCORRECTO"")"
Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad)
On Error Resume Next
Selection.AutoFilter Field:=3, Criteria1:="INCORRECTO"
MsgBox ("no concuerda el el dato de la columna primary key " & letra & " en ambos archivos")
Sheets("Diferencias").Select
salir = True
Exit Function
Else
NumeroColumna = Range(letra).Column
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
A.Columns(NumeroColumna).Copy C.Columns(1)
B.Columns(NumeroColumna).Copy C.Columns(2)
cantidad = Range("b1048576").End(xlUp).Row
Sheets("Diferencias").Select
Range("C1") = "DIFERENCIAS"
Range("C2").Select
Range("a1") = "Version 1"
Range("b1") = "Version 2"
cantidad = Range("b1048576").End(xlUp).Row
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-2],C[-1],1,0),""NO ENCONTRADO"")"
Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad)
On Error Resume Next
Selection.AutoFilter Field:=3, Criteria1:="NO ENCONTRADO"
Range("c:c").Select
cantidad = Worksheets("Diferencias").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If cantidad > 0 Then
salir = True
MsgBox (" Los registros de Version 1 (columna A) no fueron encontrados en Version 2 (columna B) la llave primaria debe estar en ambos archivos para poder comparar")
Exit Function
End If
C.Cells.ClearContents
C.Cells.ClearContents
Sheets("Diferencias").Select
End If
End Function
'------------------------------------------------------------------------------------------
'' me sirve para quitar todos los filtros de las hojas
Function Filtros()
For Each Hojas In ActiveWorkbook.Sheets
If Hojas.AutoFilterMode Then
Hoja.Range("A1").AutoFilter
End If
Next Hojas
End Function
COMPARTE EL EXCEL AMIGO
Public A, B, C As Worksheet
Public PrimerError As Boolean
Public x, y, z As Long
Public letra As String
Public salir As Boolean
Public Gestionaerror As Integer
Public segundos1 As Single
Public segundos2 As Single
Sub Comparar()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
segundos1 = Timer()
Dim cantidad As Long
Dim cantidad2 As Long
'UserForm1.Show
'strArchivo = Application.GetOpenFilename
salir = False
letra = ThisWorkbook.Sheets("Parametros").Range("Letra")
Sheets("Diferencias").Select
Cells.Delete Shift:=xlUp
Call Filtros
Sheets("Version 1").Select
cantidad = Range("b1048576").End(xlUp).Row
Call Espacios
Call Ordenar
Sheets("Version 2").Select
cantidad2 = Range("b1048576").End(xlUp).Row
Call Espacios
Call Ordenar
Call Validar_LLaves
Gestionaerror:
If (salir = True) Then
Exit Sub
End If
Call CompararHojas
Sheets("Diferencias").Select
If (Range("a2").Value "" Or Range("b2").Value "") Then
MsgBox ("Revisar Archivo, contiene informacion diferente")
Else
MsgBox ("No hay registros diferentes")
Application.StatusBar = False
End If
End Sub
'------------------------------------------------------------------------------------------
Function CompararHojas()
Sheets("Version 1").Select
cantidad = Range("b1048576").End(xlUp).Row
On Error Resume Next
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
C.Cells.ClearContents
'A.Cells.Interior.Color = xlNone
'B.Cells.Interior.Color = xlNone
C.Cells.Interior.Color = xlNone
A.Rows(1).Copy C.Rows(1)
C.Activate
z = 1
j = 1
k = 1
For x = 1 To A.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
PrimerError = False
For y = 1 To A.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ultima2 = Range("b1048576").End(xlUp).Row
Porcentaje = (conteo * 100) / cantidad
Application.StatusBar = "Porcentaje Procesado: " & Round(Porcentaje, 0) & " %" & " Tiempo de ejecucion: " & Round((segundos2 - segundos1) / 60, 1) & " Minutos"
If A.Cells(x, y) B.Cells(x, y) Then
If PrimerError = False Then
PrimerError = True
z = z + 1
k = k + 1
B.Rows(x).Copy C.Rows(z)
End If
'C.Cells(z, y).Font.Color = vbRed
C.Cells(z, y).Font.Bold = True
C.Cells(z, y).Interior.ColorIndex = 3
bandera = True
ElseIf (bandera True) Then
bandera = False
End If
Next y
z = z + 1
j = j + 1
If (bandera True) Then
If (k > 0) Then
k = k - 1
C.Rows(ultima2).Delete
End If
A.Rows(j).Copy C.Rows(ultima2)
z = z - 1
Else
k = k + 1
A.Rows(j).Copy C.Rows(z)
bandera = False
End If
conteo = conteo + 1
segundos2 = Timer()
Next x
A.Rows(1).Copy
C.Rows(1).Insert Shift:=xlDown
'C.Cells.Interior.Color = 3
End Function
'' me sirve para quitar los espacios al comienzo y al final de todas las columnas
Function Espacios()
With ActiveSheet.UsedRange
.Value = Evaluate("if(row(" & .Address & "),clean(trim(" & .Address & ")))")
End With
End Function
'------------------------------------------------------------------------------------------
'' me sirve para ordenar en orden ascendente por la clave primaria
Function Ordenar()
On Error Resume Next
Range(letra).Sort Key1:=Range(letra), Order1:=xlAscending, Header:=xlYes
End Function
'------------------------------------------------------------------------------------------
Function Validar_LLaves()
Dim Celda As Range
Sheets("Version 1").Select
If (cantidad cantidad2) Then
NumeroColumna = Range(letra).Column
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
A.Columns(NumeroColumna).Copy C.Columns(1)
B.Columns(NumeroColumna).Copy C.Columns(2)
cantidad = Range("b1048576").End(xlUp).Row
Sheets("Diferencias").Select
Range("a1") = "Version 1"
Range("b1") = "Version 2"
Range("C1") = "INCONSISTENCIAS"
Range("C2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-2]=RC[-1],""CORRECTO"",""INCORRECTO"")"
Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad)
On Error Resume Next
Selection.AutoFilter Field:=3, Criteria1:="INCORRECTO"
MsgBox ("no concuerda el el dato de la columna primary key " & letra & " en ambos archivos")
Sheets("Diferencias").Select
salir = True
Exit Function
Else
NumeroColumna = Range(letra).Column
Set A = ThisWorkbook.Sheets("Version 1")
Set B = ThisWorkbook.Sheets("Version 2")
Set C = ThisWorkbook.Sheets("Diferencias")
A.Columns(NumeroColumna).Copy C.Columns(1)
B.Columns(NumeroColumna).Copy C.Columns(2)
cantidad = Range("b1048576").End(xlUp).Row
Sheets("Diferencias").Select
Range("C1") = "DIFERENCIAS"
Range("C2").Select
Range("a1") = "Version 1"
Range("b1") = "Version 2"
cantidad = Range("b1048576").End(xlUp).Row
Range("C2").Select
ActiveCell.FormulaR1C1 = _
"=IFERROR(VLOOKUP(RC[-2],C[-1],1,0),""NO ENCONTRADO"")"
Selection.AutoFill Destination:=ActiveSheet.Range("c2:c" & cantidad)
On Error Resume Next
Selection.AutoFilter Field:=3, Criteria1:="NO ENCONTRADO"
Range("c:c").Select
cantidad = Worksheets("Diferencias").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
If cantidad > 0 Then
salir = True
MsgBox (" Los registros de Version 1 (columna A) no fueron encontrados en Version 2 (columna B) la llave primaria debe estar en ambos archivos para poder comparar")
Exit Function
End If
C.Cells.ClearContents
C.Cells.ClearContents
Sheets("Diferencias").Select
End If
End Function
'------------------------------------------------------------------------------------------
'' me sirve para quitar todos los filtros de las hojas
Function Filtros()
For Each Hojas In ActiveWorkbook.Sheets
If Hojas.AutoFilterMode Then
Hoja.Range("A1").AutoFilter
End If
Next Hojas
End Function