Macro marcar, y numerar según repetidos
Tengo dos columnas una "D" y "O" con numero presupuestos y otra con valor: Necesito que orden por presupuesto y después por valor, busque los datos repetidos y los pinte de verde, pero si presupuesto y valor en la misma línea están pintados, significa que están repetidos en las dos columnas, en otra columna en la misma línea marque un numero, si están ordenados debería marcar todas las líneas que se repitan, y así hasta terminar todos lo registros, la idea es que pueda filtrar después por la columna con los números ingresados
1 Respuesta
Respuesta de Dante Amor
2
Te anexo la macro.
Cambia en la macro la siguiente información:
c1 = "A" 'columna inicial de datos c2 = "Z" 'columna final de datos f1 = 1 'fila con encabezados col = "AA" 'columna con la numeración
'
Sub Marcar_Y_Numerar()
'
' Por Dante Amor
'
'
c1 = "A" 'columna inicial de datos
c2 = "Z" 'columna final de datos
f1 = 1 'fila con encabezados
col = "AA" 'columna con la numeración
'
Application.ScreenUpdating = False
If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
'
f2 = Range("D" & Rows.Count).End(xlUp).Row
n = 1
coln = Columns(col).Column
Range(Cells(f1 + 1, coln), Cells(f2, coln + 2)).ClearContents
Range("D:D, O:O").Interior.ColorIndex = xlNone
'
With ActiveSheet.Sort
.SortFields.Clear
.SortFields.Add Key:=Range("D" & f1 + 1 & ":D" & f2), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("O" & f1 + 1 & ":O" & f2), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range(c1 & f1 & ":" & c2 & f2)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
With Range(Cells(f1 + 1, coln + 1), Cells(f2, coln + 1))
.FormulaR1C1 = "=RC4&RC15"
.Value = .Value
End With
Columns(coln + 1).Copy Columns(coln + 2)
ActiveSheet.Range(Cells(f1 + 1, coln + 2), Cells(f2, coln + 2)).RemoveDuplicates _
Columns:=1, Header:=xlNo
'
Set r = Columns(coln + 1)
For i = 2 To Cells(Rows.Count, coln + 2).End(xlUp).Row
Set b = r.Find(Cells(i, coln + 2), LookAt:=xlWhole)
If Not b Is Nothing Then
celda = b.Address
una = True
fila = b.Row
Do
'detalle
If una = False Then
Range("D" & b.Row & ",O" & b.Row).Interior.ColorIndex = 4
Cells(b.Row, coln) = n
End If
Set b = r.FindNext(b)
If Not b Is Nothing And b.Address <> celda Then
Range("D" & fila & ",O" & fila).Interior.ColorIndex = 4
Cells(fila, coln) = n
una = False
End If
Loop While Not b Is Nothing And b.Address <> celda
If una = False Then
n = n + 1
End If
End If
Next
Columns(coln + 1).Clear
Columns(coln + 2).Clear
Application.ScreenUpdating = True
MsgBox "Fin"
End Sub
.
'S aludos. Dante Amor. Recuerda valorar la respuesta. G racias
.
Avísame cualquier duda
.
