Coincidencia 3 valores por filas

La macro que sigue de esta imagen te dejaria el resultado asi

y esta es la macro

Option Base 1
Sub COPIAR_DATOS()
Dim FUNCION As WorksheetFunction
Dim DATOS As Range, DATOS2 As Range
Set FUNCION = WorksheetFunction
Set DATOS = Range("B3").CurrentRegion
With DATOS
    F = .Rows.Count: C = .Columns.Count
    .Columns(C + 2).CurrentRegion.Resize(, 100).Clear
    Set DATOS2 = .Columns(C + 2).Resize(F, C)
    .Copy: DATOS2.PasteSpecial xlPasteAll
End With
Set DATOS2 = DATOS2.Columns(2).Resize(F, C - 1)
With DATOS2
    C = .Columns.Count
    ReDim MATRIZ(C): ReDim MATRIZ2(F)
    For I = 1 To F
        For J = 1 To C
            MATRIZ(J) = .Cells(I, J)
        Next J
        MATRIZ2(I) = Join(MATRIZ())
    Next I
    Range(.Columns(C + 1).Address) = FUNCION.Transpose(MATRIZ2)
    Set DATOS2 = .CurrentRegion
End With
Erase MATRIZ
With DATOS2
    C = .Columns.Count
    Set TABLA = .Columns(C + 1).Resize(F, 1)
    MATRIZ3 = TABLA
    For I = 1 To F
        MATRIZ3(I, 1) = FUNCION.CountIf(.Columns(C), .Cells(I, C))
    Next I
    Range(TABLA.Address) = MATRIZ3
    Set DATOS2 = .CurrentRegion
End With
With DATOS2
    C = .Columns.Count
    .Sort KEY1:=Range(.Columns(C).Address), ORDER1:=xlDescending
    Set TABLA = .Columns(C + 3).Resize(F, C)
    .Copy: TABLA.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    .Columns(5).Resize(F, 2).EntireColumn.Delete
    Set DATOS2 = .CurrentRegion
End With
With DATOS2
    C = .Columns.Count
    .Rows(0) = Array("Orden", "Nº", "Nº", "Nº")
    .Rows(0).Font.Bold = True
    .EntireColumn.AutoFit
    .Columns(2).Resize(F, C - 1).Interior.ColorIndex = 37
    .Columns(1).Interior.ColorIndex = 4
    .Rows(0).Interior.ColorIndex = 44
End With
With TABLA
    .RemoveDuplicates Columns:=5
    .Columns(1).Value = .Columns(C + 2).Value
    .Columns(5).Resize(F, 2).Clear
    Set TABLA = .CurrentRegion
End With
With TABLA
    C = .Columns.Count: F = .Rows.Count
    .Rows(0) = Array("Coincidencias", "Nº", "Nº", "Nº")
    .Rows(0).Font.Bold = True
    .EntireColumn.AutoFit
    .Columns(2).Resize(F, C - 1).Interior.ColorIndex = 37
    .Columns(1).Interior.ColorIndex = 4
    .Rows(0).Interior.ColorIndex = 44
    .Columns(0).EntireColumn.Delete
End With

Si, en un principio a simple vista parece ser lo que busco, después la mirare más tranquilo y comprobare con filtros (que es la única forma que se de comprobar lo que da la macro).

En breve confirmo, muchas gracias de todas formas.

Saludos...

Todo genial, lo único por decir algo es que realmente ahora trabaja la macro sobre una base de datos hasta la fila 227 y lógicamente le cuesta algo más, parece quedarse pillada unos segundos pero al final hace su trabajo.

La base de datos puede llegar en algún momento hasta ejemplo la fila 1.000

¿Se puede hacer alguna cosilla en la macro para este fin?

De todas maneras genial.

Saludos...

Haciendo una pequeñas modificaciones a la macro el resultado es el siguiente con más de 2500 registros el tiempo en un equipo antiguo es de 9 segundos

Option Base 1
Option Explicit
Sub copiar_datos()
Dim datos As Range, datos2 As Range, tabla As Range
Dim f As Integer, c As Integer, cuenta As Integer
Dim i As Integer, j As Integer, inicio As Date
Dim matriz() As Variant, matriz2() As String
Dim funcion As WorksheetFunction
Dim cadena As String, fin As Date, tiempo As Date
inicio = Time
With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With
ActiveSheet.DisplayPageBreaks = False
Set funcion = WorksheetFunction
Set datos = Range("b3").CurrentRegion
With datos
    f = .Rows.Count:    c = .Columns.Count
    .Columns(c + 3).Offset(-2, 0).Resize(f, 1000).Clear
    Set datos2 = .Columns(c + 3).Resize(f, c)
    datos.Copy: datos2.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
End With
With datos2
    Set datos2 = .Columns(2).Resize(f, c - 1)
End With
ReDim matriz(3): ReDim matriz2(f)
With datos2
    For i = 1 To f
        For j = 1 To c - 1
            matriz(j) = .Cells(i, j)
        Next j
        matriz2(i) = Join(matriz())
    Next i
    Range(.Columns(c).Address) = funcion.Transpose(matriz2)
    Set datos2 = .CurrentRegion
End With
With datos2
    c = .Columns.Count
    For i = 1 To f
        cadena = .Cells(i, c)
        cuenta = funcion.CountIf(.Columns(c), cadena)
        matriz2(i) = cuenta
    Next i
    Range(.Columns(c + 1).Address) = funcion.Transpose(matriz2)
    Set datos2 = .CurrentRegion
End With
With datos2
     c = .Columns.Count
    .Sort _
    key1:=Range(.Columns(c).Address), order1:=xlDescending, _
    key2:=Range(.Columns(c - 1).Address), order1:=xlAscending
    .EntireColumn.AutoFit
    Set tabla = .Columns(c + 3).Resize(f, c)
    .Copy: tabla.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
    .Columns(5).Resize(f, 2).EntireColumn.Delete
    .CurrentRegion.EntireColumn.AutoFit
End With
With tabla
    .Columns(1).Value = .Columns(c).Value
    .RemoveDuplicates Columns:=5
    .Columns(5).Resize(f, 2).EntireColumn.Delete
    Set tabla = .CurrentRegion
End With
With tabla
    .Rows(0) = Array("Coincidencias", "Nº", "Nº", "Nº")
    .Rows(0).Font.Bold = True
    .Rows(0).Interior.ColorIndex = 44
    .Columns(1).Interior.ColorIndex = 4
    .Columns(2).Resize(f, 3).Resize(f, 3).Interior.ColorIndex = 37
    .EntireColumn.AutoFit
End With
With datos2
    .Rows(0) = Array("Orden", "Nº", "Nº", "Nº")
    .Rows(0).Font.Bold = True
    .Rows(0).Interior.ColorIndex = 44
    .Columns(1).Interior.ColorIndex = 4
    .Columns(2).Resize(f, 3).Resize(f, 3).Interior.ColorIndex = 37
    .EntireColumn.AutoFit
End With
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .CutCopyMode = False
End With
ActiveSheet.DisplayPageBreaks = False
fin = Time
tiempo = fin - inicio
MsgBox (f & " filas procesadas en " & Second(tiempo) & " segundos"), vbInformation, "AVISO"
Set tabla = Nothing: Set datos = Nothing: Set datos2 = Nothing
End Sub

Perfecto 2 segundos, ya por ultimo se podría ajustar para que el resumen de coincidencias se copiara en L:O en lugar de M:P, miro la macro y no quiero tocar y estropear nada.

Saludos...

Prueba poniendo en K3:

=SUMA(1*($B$3:$B$37&$C$3:$C$37&$D$3:$D$37=L3&M3&N3))

copiar y pegar en K4 y K5

Se trata de una fórmula matricial, por lo que hay que introducirla puslando mayúsculas control entrada al mismo tiempo.

La fórmula devuelve 2 apariciones de 914 en vez de 1, que creo que es lo correcto (filas 12 y 22)

Saludos_

Si, ¿pero da solo el resultado de coincidencias? Los resultados de L:N son manuales para tratar de explicarme, los datos de este rango L:N los tiene que dar una fórmula o función x.

Saludos...