Te anexo la macro
Private Sub Worksheet_Change(ByVal Target As Range)
'Por.Dante Amor
If Not Intersect(Target, Range("A:E, G:G")) Is Nothing Then
Application.ScreenUpdating = False
For Each c In Target
Range("H2:I2").Copy Cells(c.Row, "H")
Next
Application.EnableEvents = False
u = Range("A" & Rows.Count).End(xlUp).Row
'
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("B2:B" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("D2:D" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SortFields.Add Key:=Range("E2:E" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:I" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
an1 = Cells(2, "B")
an2 = Cells(2, "D")
an3 = Cells(2, "E")
con = 0
For i = 2 To u
If an1 = Cells(i, "B") And _
an2 = Cells(i, "D") And _
an3 = Cells(i, "E") Then
con = con + 1
Else
con = 1
End If
Cells(i, "F") = con
an1 = Cells(i, "B")
an2 = Cells(i, "D")
an3 = Cells(i, "E")
Next
'
With ActiveWorkbook.Worksheets("Hoja1").Sort
.SortFields.Clear
.SortFields.Add Key:=Range("A2:A" & u), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("A1:I" & u)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'
Application.EnableEvents = True
End If
End Sub
Saludos. Dante Amor