excel - una - Combina Filas con valores duplicados, combina celdas si son diferentes

formula para buscar datos repetidos en excel

Question

Tengo una pregunta similar para [combinar Filas con valores duplicados] [1] Excel VBA - Combina filas con valores duplicados en una celda y fusiona valores en otra celda

Tengo datos en este formato (las filas están ordenadas)

Pub     ID      CH      Ref
no      15      1      t2
no      15      1      t88
yes     15      2      t3
yes     15      2      t3
yes     15      2      t6

compare las filas adyacentes (por ejemplo, fila 4 y 5), si col 2 y 3 coinciden, si col col 4 merge col4 diferente, elimine la fila. si col 2,3,4 coincide y luego borra la fila, no combine col 4

Salida deseada

key     ID      CH      Text  
no      15      1       t2   t88
yes     15      2       t3   t6

Esta primera sección de código no funciona bien

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        Dim columnToMatch1 As Integer: columnToMatch1 = 2
        Dim columnToMatch2 As Integer: columnToMatch2 = 3
        Dim columnToConcatenate As Integer: columnToConcatenate = 4


        lngRow = .Cells(65536, columnToMatch1).End(xlUp).row
        .Cells(columnToMatch1).CurrentRegion.Sort key1:=.Cells(columnToMatch1), Header:=xlYes
        .Cells(columnToMatch2).CurrentRegion.Sort key1:=.Cells(columnToMatch2), Header:=xlYes

        Do
            If .Cells(lngRow, columnToMatch1) = .Cells(lngRow - 1, columnToMatch1) Then ''check col 2 row lngRow, lngRow-1
              If .Cells(lngRow, columnToMatch2) = .Cells(lngRow - 1, columnToMatch2) Then ''check col 3 row lngRow, lngRow-1
                 If .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow, columnToConcatenate) Then
                    Else
                    .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & "; " & .Cells(lngRow, columnToConcatenate)
                 End If
                .Rows(lngRow).Delete
              End If
            End If
            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With

Salida real incorrecta porque cuando las celdas se combinan t3 no coincidirá con t3; t6, mi comparación en col 4 solo funcionará en casos muy simples solamente.

Salida real

key ID  CH  Text
no  15  1   t2; t88
yes 15  2   t3; t3; t6

Por lo tanto, tuve que agregar estas dos secciones para dividir las celdas Concatenar y luego eliminar duplicados

''split cell in Col d to col e+ delimited by ;
        With Range("D2:D6", Range("D" & Rows.Count).End(xlUp))
            .Replace ";", " ", xlPart
            .TextToColumns other:=True
        End With

 ''remove duplicates in each row

    Dim x, y(), i&, j&, k&, s$
    With ActiveSheet.UsedRange
        x = .Value: ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2))
        For i = 1 To UBound(x)
            For j = 1 To UBound(x, 2)
                If Len(x(i, j)) Then
                    If InStr(s & "|", "|" & x(i, j) & "|") = 0 Then _
                       s = s & "|" & x(i, j): k = k + 1: y(i, k) = x(i, j)
                End If
            Next j: s = vbNullString: k = 0
        Next i
        .Value = y()
    End With
    End Sub

Con salida de código adicional es

Pub ID  CH  Ref 
no  15  1   t2  t88
yes 15  2   t3  t6

Pregunta: ¿Debe haber una manera mucho más fácil de hacer esto bien que usar tres métodos diferentes? ¿Qué hay de insertar nuevas columnas 5+ si los artículos col 4 no coinciden?

Nota: Eliminar el código duplicado se encontró desde user nilem en excelforum.

Editar: Col 1 siempre será igual si Col 2 y 3 coinciden. Si la solución es mucho más fácil, podemos suponer que Col 1 está en blanco e ignorar los datos.

He imprimido una tabla de búsqueda de libros y necesito convertirla a un formato simple que se usará en equipos que usan un lenguaje de 1960 que tiene comandos muy limitados. Intento preformatear estos datos, así que solo necesito buscar una fila que tenga toda la información.

La salida final de Col D puede estar en col D con delimitador o en col DK (solo 8 max Ref) porque voy a analizar para usar en otra máquina. Cualquier método es más fácil.

Answer 1

Como escribí anteriormente, iteraría a través de los datos y recogería cosas en el Objeto definido por el usuario. No es necesario que los datos se clasifiquen en este método; y los REF duplicados se omitirán.

Una ventaja de un objeto definido por el usuario es que facilita la depuración ya que puede ver más claramente lo que ha hecho.

Combinamos todas las líneas donde ID y CH son iguales, utilizando la propiedad del objeto Collection para generar un error si se utilizan claves idénticas.

En la medida en que se combinen las Refs en una sola celda con un delimitador, frente a las celdas individuales en las columnas D: K, cualquiera puede hacerse simplemente. Elegí separar en columnas, pero cambiarlo para combinarlo en una sola columna sería trivial.

Después de insertar el módulo de clase, debe cambiarle el nombre: cID_CH

Notará que coloqué los resultados en hojas de trabajo separadas. Podría sobrescribir los datos originales, pero desaconsejaría eso.

Módulo de clase

Option Explicit
Private pID As Long
Private pCH As Long
Private pPUB As String
Private pREF As String
Private pcolREF As Collection

Public Property Get ID() As Long
    ID = pID
End Property
Public Property Let ID(Value As Long)
    pID = Value
End Property

Public Property Get CH() As Long
    CH = pCH
End Property
Public Property Let CH(Value As Long)
    pCH = Value
End Property

Public Property Get PUB() As String
    PUB = pPUB
End Property
Public Property Let PUB(Value As String)
    pPUB = Value
End Property

Public Property Get REF() As String
    REF = pREF
End Property
Public Property Let REF(Value As String)
    pREF = Value
End Property

Public Property Get colREF() As Collection
    Set colREF = pcolREF
End Property

Public Sub ADD(refVAL As String)
    On Error Resume Next
        pcolREF.ADD refVAL, refVAL
    On Error GoTo 0
End Sub

Private Sub Class_Initialize()
    Set pcolREF = New Collection
End Sub

Módulo regular

Option Explicit
Sub CombineDUPS()
    Dim wsSRC As Worksheet, wsRES As Worksheet
    Dim vSRC As Variant, vRES() As Variant, rRES As Range
    Dim cI As cID_CH, colI As Collection
    Dim I As Long, J As Long
    Dim S As String

''Set source and results worksheets and results range
Set wsSRC = Worksheets("sheet1")
Set wsRES = Worksheets("sheet2")
Set rRES = wsRES.Cells(1, 1)

''Get Source data
With wsSRC
    vSRC = .Range("A2", .Cells(.Rows.Count, "D").End(xlUp))
End With

''Collect and combine data
Set colI = New Collection
On Error Resume Next
For I = 1 To UBound(vSRC, 1)
    Set cI = New cID_CH
    With cI
        .PUB = vSRC(I, 1)
        .ID = vSRC(I, 2)
        .CH = vSRC(I, 3)
        .REF = vSRC(I, 4)
        .ADD .REF
        S = CStr(.ID & "|" & .CH)
        colI.ADD cI, S
        If Err.Number = 457 Then
            Err.Clear
            colI(S).ADD .REF
        ElseIf Err.Number <> 0 Then
            Debug.Print Err.Number, Err.Description
            Stop
        End If
    End With
Next I
On Error GoTo 0

''Create and populate Results Array
ReDim vRES(0 To colI.Count, 1 To 11)

''Header row
vRES(0, 1) = "Pub"
vRES(0, 2) = "ID"
vRES(0, 3) = "CH"
vRES(0, 4) = "Ref"

''populate array
For I = 1 To colI.Count
    With colI(I)
        vRES(I, 1) = .PUB
        vRES(I, 2) = .ID
        vRES(I, 3) = .CH
        For J = 1 To .colREF.Count
            vRES(I, J + 3) = .colREF(J)
        Next J
    End With
Next I

''Write the results to the worksheet
Set rRES = rRES.Resize(UBound(vRES, 1) + 1, UBound(vRES, 2))
With rRES
    .EntireColumn.Clear
    .Value = vRES
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
        Range(.Cells(4), .Cells(11)).HorizontalAlignment = xlCenterAcrossSelection
    End With
    .EntireColumn.AutoFit
End With

End Sub

Original

Resultados procesados

Answer 2

La práctica canónica para eliminar filas es comenzar en la parte inferior y avanzar hacia la parte superior. De esta manera, las filas no se saltan. El truco aquí es encontrar filas por encima de la posición actual que coincidan con las columnas B y C y concatenar las cadenas de la columna D antes de eliminar la fila. Hay varias buenas fórmulas de hoja de cálculo que pueden adquirir el número de fila de una coincidencia de dos columnas. Poniendo en práctica uno de ellos con la application.Evaluate Evaluar sería el método más conveniente para recopilar los valores de la columna D.

Sub dedupe_and_collect()
    Dim rw As Long, mr As Long, wsn As String

    With ActiveSheet   ''<- set this worksheet reference properly!
        wsn = .Name
        With .Cells(1, 1).CurrentRegion
            .RemoveDuplicates Columns:=Array(2, 3, 4), Header:=xlYes
        End With
        With .Cells(1, 1).CurrentRegion  ''redefinition after duplicate removal
            For rw = .Rows.Count To 2 Step -1 ''walk backwards when deleting rows
                If Application.CountIfs(.Columns(2), .Cells(rw, 2).Value, .Columns(3), .Cells(rw, 3).Value) > 1 Then
                    mr = Application.Evaluate("MIN(INDEX(ROW(1:" & rw & ")+((''" & wsn & "''!B1:B" & rw & "<>''" & wsn & "''!B" & rw & ")+(''" & wsn & "''!C1:C" & rw & "<>''" & wsn & "''!C" & rw & "))*1E+99, , ))")
                    ''concatenate column D
                    ''.Cells(mr, 4) = .Cells(mr, 4).Value & "; " & .Cells(rw, 4).Value
                    ''next free column from column D
                    .Cells(mr, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 4).Value
                    .Rows(rw).EntireRow.Delete
                End If
            Next rw
        End With
    End With
End Sub

La eliminación de registros en una coincidencia de tres columnas se realiza con el equivalente VBA del comando Fecha ► Herramientas de datos ► Eliminar duplicados. Esto solo considera las columnas B, C y D y elimina los duplicados inferiores (manteniendo los más cercanos a la fila 1). Si la Columna A es importante a este respecto, se debería agregar codificación adicional.

No estoy seguro de si quería la columna D como cadena delimitada o celdas separadas como resultado final. ¿Podrías aclarar?

Answer 3

variante usando el diccionario a continuación

Sub test()
    Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
    Dic.Comparemode = vbTextCompare
    Dim Cl As Range, x$, y$, i&, Key As Variant
    For Each Cl In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row)
        x = Cl.Value & "|" & Cl.Offset(, 1).Value
        y = Cl.Offset(, 2).Value
        If Not Dic.exists(x) Then
            Dic.Add x, Cl.Offset(, -1).Value & "|" & y & "|"
        ElseIf Dic.exists(x) And Not LCase(Dic(x)) Like "*|" & LCase(y) & "|*" Then
            Dic(x) = Dic(x) & "|" & y & "|"
        End If
    Next Cl
    Range("A2:D" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents
    i = 2
    For Each Key In Dic
        Cells(i, "A") = Split(Dic(Key), "|")(0)
        Range(Cells(i, "B"), Cells(i, "C")) = Split(Key, "|")
        Cells(i, "D") = Replace(Split(Replace(Dic(Key), "||", ";"), "|")(1), ":", ";")
        i = i + 1
    Next Key
    Set Dic = Nothing
End Sub

antes de

después