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
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

.

Añade tu respuesta

Haz clic para o

Más respuestas relacionadas