Macro listar valores únicos por tipologías eliminando duplicados
Anteriormente, pregunté sobre la macro para listar valores únicos por tipologías, me gustaría saber como solucionar un pequeño inconveniente y es que las tipologías se duplican dentro de la celda de resultados.
Haría falta que una vez calcule las tipologías por usuario y las pase a texto que aquellas tipologías que se puedan ver repetidas dentro de un usuario/sesión solo aparezcan una vez por usuario.
Ejemplo: Si el usuario A ha hecho en dos sesiones la tipología AG que éste solo se muestre una vez en el listado de la macro y no dos veces.
¡Muchas gracias!
Macro utilizada:
Sub ObtenerID()'x Elsamatilde'copio col A a col C y obtengo datos únicos Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy _ Destination:=Range("C1") ActiveSheet.Range("$C$1:$C$" & Range("C" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo'recorre col C y busca las tipologías para agregarlas en col DRange("C2").Selectfilx = 2While ActiveCell <> ""Set busco = Range("A:A").Find(ActiveCell.Value, LookIn:=xlValues, lookat:=xlWhole)If Not busco Is Nothing Then 'si encontró el dato lo agrega a la cadena fil1 = busco.Row Do Range("D" & ActiveCell.Row) = Range("D" & ActiveCell.Row) & busco.Offset(0, 1) & ", " Set busco = Range("A:A").FindNext(busco) Loop While Not busco Is Nothing And busco.Row <> fil1End If'paso a la fila sgteActiveCell.Offset(1, 0).SelectWendEnd Sub
1 Respuesta
Tomé la macro anterior, por lo tanto la Tipología sigue tomándola de la col B... ya te respondí en consulta anterior 2 modos de ajustar a otras col.
Sub ObtenerID()
'x Elsamatilde
'copio col A a col C y obtengo datos únicos
Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row).Copy _
Destination:=Range("C1")
ActiveSheet.Range("$C$1:$C$" & Range("C" & Rows.Count).End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo
'recorre col C y busca las tipologías para agregarlas en col D
Range("C2").Select
filx = 2
While ActiveCell <> ""
Set busco = Range("A:A").Find(ActiveCell.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not busco Is Nothing Then
'si encontró el dato lo agrega a la cadena
fil1 = busco.Row
Do
'INSTR busca cierto contenido en una cadena. si devuelve 0 es que no lo encontró
If InStr(1, Range("D" & ActiveCell.Row), busco.Offset(0, 1)) = 0 Then
'no está y lo agrego
Range("D" & ActiveCell.Row) = Range("D" & ActiveCell.Row) & busco.Offset(0, 1) & ", "
End If
Set busco = Range("A:A").FindNext(busco)
Loop While Not busco Is Nothing And busco.Row <> fil1
End If
'paso a la fila sgte
ActiveCell.Offset(1, 0).Select
Wend
End Sub
¡Gracias!
Te recuerdo que la consulta sigue aún como 'pendiente'.. por favor valora desde el desplegable que encontrarás a continuación.
Sdos!
