Anónimo
Formato de celdas en excel
Quiero dar formato a una hoja de excel con datos duplicados, pero sólo quiero que me señale los datos que estén duplicados en celdas contiguas.
Por ejemplo 0 - 0 -1 -0 - 1 - 2 -3 sólo quiero que me dé formato a los dos ceros que están juntos.
Muchas graciqas.
Por ejemplo 0 - 0 -1 -0 - 1 - 2 -3 sólo quiero que me dé formato a los dos ceros que están juntos.
Muchas graciqas.
1 Respuesta
Respuesta de santiagomf
1
Prueba con el siguiente código.
Si no he entendido mal es, más o menos, lo que quieres. De todas formas pienso que lo puedes retocar tu mismo para ajustarlo a tus necesidades.
Option Explicit
Sub marcarDuplicadosJuntos()
Dim miHoja As Worksheet
Dim ultimaCelda As String
Dim maxLin As Long
Dim maxCol As Long
Dim i As Integer
Dim j As Integer
Set miHoja = ActiveSheet
' Localizamos la última fila y columna de la página
ultimaCelda = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Address
maxLin = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Row
maxCol = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Column
' Quitamos el fondo a todas las celdas de la página
miHoja.Range("A1:" & ultimaCelda).Interior.ColorIndex = xlNone
' Comprobamos los duplicados por columnas
For i = 1 To maxLin
For j = 1 To maxCol - 1
If miHoja.Cells(i, j) = miHoja.Cells(i, j + 1) Then
' Marcamos las dos celdas
miHoja.Cells(i, j).Interior.ColorIndex = 6
miHoja.Cells(i, j).Interior.Pattern = xlSolid
miHoja.Cells(i, j + 1).Interior.ColorIndex = 6
miHoja.Cells(i, j + 1).Interior.Pattern = xlSolid
End If
Next j
Next i
' Y hacemos lo mismo por filas
For j = 1 To maxCol
For i = 1 To maxLin - 1
If miHoja.Cells(i, j) = miHoja.Cells(i + 1, j) Then
' Marcamos las dos celdas
miHoja.Cells(i, j).Interior.ColorIndex = 6
miHoja.Cells(i, j).Interior.Pattern = xlSolid
miHoja.Cells(i + 1, j).Interior.ColorIndex = 6
miHoja.Cells(i + 1, j).Interior.Pattern = xlSolid
End If
Next i
Next j
' Terminado
MsgBox "Ya están marcadas las celdas adyacentes iguales"
End Sub
Si no he entendido mal es, más o menos, lo que quieres. De todas formas pienso que lo puedes retocar tu mismo para ajustarlo a tus necesidades.
Option Explicit
Sub marcarDuplicadosJuntos()
Dim miHoja As Worksheet
Dim ultimaCelda As String
Dim maxLin As Long
Dim maxCol As Long
Dim i As Integer
Dim j As Integer
Set miHoja = ActiveSheet
' Localizamos la última fila y columna de la página
ultimaCelda = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Address
maxLin = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Row
maxCol = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Column
' Quitamos el fondo a todas las celdas de la página
miHoja.Range("A1:" & ultimaCelda).Interior.ColorIndex = xlNone
' Comprobamos los duplicados por columnas
For i = 1 To maxLin
For j = 1 To maxCol - 1
If miHoja.Cells(i, j) = miHoja.Cells(i, j + 1) Then
' Marcamos las dos celdas
miHoja.Cells(i, j).Interior.ColorIndex = 6
miHoja.Cells(i, j).Interior.Pattern = xlSolid
miHoja.Cells(i, j + 1).Interior.ColorIndex = 6
miHoja.Cells(i, j + 1).Interior.Pattern = xlSolid
End If
Next j
Next i
' Y hacemos lo mismo por filas
For j = 1 To maxCol
For i = 1 To maxLin - 1
If miHoja.Cells(i, j) = miHoja.Cells(i + 1, j) Then
' Marcamos las dos celdas
miHoja.Cells(i, j).Interior.ColorIndex = 6
miHoja.Cells(i, j).Interior.Pattern = xlSolid
miHoja.Cells(i + 1, j).Interior.ColorIndex = 6
miHoja.Cells(i + 1, j).Interior.Pattern = xlSolid
End If
Next i
Next j
' Terminado
MsgBox "Ya están marcadas las celdas adyacentes iguales"
End Sub
Perdón por la pregunta, pero no me expliqué bien.
Lo que tengo es una quiniela en una única columna y lo que quiero es dar formato sólo y exclusivamente a los signos iguales que estén consecutivos. Por ejemplo, si salen dos (ó 3 ó 4, ...) unos seguidos me los marque por ejemplo en rojo, si son POR seguidas, me las marque en verde y si son doses me las marque en azul.
Muchas gracias.
Lo que tengo es una quiniela en una única columna y lo que quiero es dar formato sólo y exclusivamente a los signos iguales que estén consecutivos. Por ejemplo, si salen dos (ó 3 ó 4, ...) unos seguidos me los marque por ejemplo en rojo, si son POR seguidas, me las marque en verde y si son doses me las marque en azul.
Muchas gracias.
Entonces quita la parte del código que busca los duplicados por columnas y deja la comprobación por filas. El código quedará así:
Option Explicit
Sub marcarDuplicadosJuntos()
Dim miHoja As Worksheet
Dim ultimaCelda As String
Dim maxLin As Long
Dim maxCol As Long
Dim i As Integer
Dim j As Integer
Set miHoja = ActiveSheet
' Localizamos la última fila y columna de la página
ultimaCelda = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Address
maxLin = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Row
maxCol = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Column
' Quitamos el fondo a todas las celdas de la página
miHoja.Range("A1:" & ultimaCelda).Interior.ColorIndex = xlNone
' Comprobamos los duplicados por filas
For j = 1 To maxCol
For i = 1 To maxLin - 1
If miHoja.Cells(i, j) = miHoja.Cells(i + 1, j) Then
' Marcamos las dos celdas
miHoja.Cells(i, j).Interior.ColorIndex = 6
miHoja.Cells(i, j).Interior.Pattern = xlSolid
miHoja.Cells(i + 1, j).Interior.ColorIndex = 6
miHoja.Cells(i + 1, j).Interior.Pattern = xlSolid
End If
Next i
Next j
' Terminado
MsgBox "Ya están marcadas las celdas adyacentes iguales"
End Sub
Option Explicit
Sub marcarDuplicadosJuntos()
Dim miHoja As Worksheet
Dim ultimaCelda As String
Dim maxLin As Long
Dim maxCol As Long
Dim i As Integer
Dim j As Integer
Set miHoja = ActiveSheet
' Localizamos la última fila y columna de la página
ultimaCelda = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Address
maxLin = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Row
maxCol = miHoja.Cells.SpecialCells(xlCellTypeLastCell).Column
' Quitamos el fondo a todas las celdas de la página
miHoja.Range("A1:" & ultimaCelda).Interior.ColorIndex = xlNone
' Comprobamos los duplicados por filas
For j = 1 To maxCol
For i = 1 To maxLin - 1
If miHoja.Cells(i, j) = miHoja.Cells(i + 1, j) Then
' Marcamos las dos celdas
miHoja.Cells(i, j).Interior.ColorIndex = 6
miHoja.Cells(i, j).Interior.Pattern = xlSolid
miHoja.Cells(i + 1, j).Interior.ColorIndex = 6
miHoja.Cells(i + 1, j).Interior.Pattern = xlSolid
End If
Next i
Next j
' Terminado
MsgBox "Ya están marcadas las celdas adyacentes iguales"
End Sub
Muchas gracias, pero tengo 2 pequeños problemas
1º Me aplica el formato a toda la hoja
2º Quiero aplicar color según el valor de las celdas duplicadas (1 en rojo, por en verde y 2 en azul)
1º Me aplica el formato a toda la hoja
2º Quiero aplicar color según el valor de las celdas duplicadas (1 en rojo, por en verde y 2 en azul)
Si es que hay que sacarte los detalles con calzador. Prueba con este código:
Option Explicit
Sub marcarDuplicadosJuntos()
Const celdaInicial = "B2" ' Poner la primera celda de resultados 1x2
Const celdaFinal = "B16" ' Poner la última celda de resultados 1x2
Dim miRango As Range
Dim i As Integer
Dim j As Integer
Dim val1 As String
Dim val2 As String
Dim nuevoColor As String
Dim nColor As Integer
Set miRango = ActiveSheet.Range(celdaInicial & ":" & celdaFinal)
' Quitamos el fondo a todas las celdas del rango
miRango.Interior.ColorIndex = xlNone
' Comprobamos los duplicados por filas
For j = 1 To miRango.Columns.Count
For i = 1 To miRango.Rows.Count - 1
val1 = UCase$(miRango.Cells(i, j).Value2)
val2 = UCase$(miRango.Cells(i + 1, j).Value2)
If val1 = val2 Then
Select Case miRango.Cells(i, j)
Case 1, "1": nuevoColor = "Rojo"
Case "X", "x": nuevoColor = "Verde"
Case 2, "2": nuevoColor = "Azul"
Case Else:
If val1 = "" Then nuevoColor = "nada" Else nuevoColor = "Gris"
End Select
Select Case nuevoColor
Case "Rojo": nColor = 3
Case "Azul": nColor = 41
Case "Verde": nColor = 4
Case "Gris": nColor = 15
End Select
' Marcamos las dos celdas con el color correspondiente
miRango.Cells(i, j).Interior.ColorIndex = nColor
miRango.Cells(i, j).Interior.Pattern = xlSolid
miRango.Cells(i + 1, j).Interior.ColorIndex = nColor
miRango.Cells(i + 1, j).Interior.Pattern = xlSolid
End If
Next i
Next j
' Terminado
MsgBox "Ya están marcadas las celdas adyacentes iguales"
End Sub
Option Explicit
Sub marcarDuplicadosJuntos()
Const celdaInicial = "B2" ' Poner la primera celda de resultados 1x2
Const celdaFinal = "B16" ' Poner la última celda de resultados 1x2
Dim miRango As Range
Dim i As Integer
Dim j As Integer
Dim val1 As String
Dim val2 As String
Dim nuevoColor As String
Dim nColor As Integer
Set miRango = ActiveSheet.Range(celdaInicial & ":" & celdaFinal)
' Quitamos el fondo a todas las celdas del rango
miRango.Interior.ColorIndex = xlNone
' Comprobamos los duplicados por filas
For j = 1 To miRango.Columns.Count
For i = 1 To miRango.Rows.Count - 1
val1 = UCase$(miRango.Cells(i, j).Value2)
val2 = UCase$(miRango.Cells(i + 1, j).Value2)
If val1 = val2 Then
Select Case miRango.Cells(i, j)
Case 1, "1": nuevoColor = "Rojo"
Case "X", "x": nuevoColor = "Verde"
Case 2, "2": nuevoColor = "Azul"
Case Else:
If val1 = "" Then nuevoColor = "nada" Else nuevoColor = "Gris"
End Select
Select Case nuevoColor
Case "Rojo": nColor = 3
Case "Azul": nColor = 41
Case "Verde": nColor = 4
Case "Gris": nColor = 15
End Select
' Marcamos las dos celdas con el color correspondiente
miRango.Cells(i, j).Interior.ColorIndex = nColor
miRango.Cells(i, j).Interior.Pattern = xlSolid
miRango.Cells(i + 1, j).Interior.ColorIndex = nColor
miRango.Cells(i + 1, j).Interior.Pattern = xlSolid
End If
Next i
Next j
' Terminado
MsgBox "Ya están marcadas las celdas adyacentes iguales"
End Sub