Merge met voorwaarden

[Klikmaar]

Stel: Ik heb een excelsheet met 12 regels.
2 kolommen hebben dezelfde waarde in kolom D en G, en een specifieke waarde in kolom L die soms gelijk is en soms ook niet.
De waarden in kolom M, N,O en P zijn nooit gelijktijdig ingevuld, dus als de ene rij een waarde in kolom M heeft, dan zijn de kolommen N,O en P leeg.
Nu is het de bedoeling dat deze 3 regels samengevoegd worden in 1 rij, tenzij de waarde in kolom L niet gelijk is, waarbij de waarde in kolom D en G overgenomen worden en kolom Q (nieuwe kolom) de waarde bevat van M,N,O en P. (komma gescheiden)
Als de waarde in kolom L verschillende is, dan dient deze rij gewoon te blijven bestaan, dus elke unieke waarde van L, blijft als rij bestaan. De waarde van M,N,O of P moet dan in de kolom Q komen te staan.
Hierna zullen de overbodige geworden rijen verwijderd moeten worden en zal het programma de volgende 3 moeten zoeken en detzelfde procedure moeten volgen totdat het einde van de excelsheet is bereikt of in een nieuw excelsheet schrijven.

Ik heb een stukje code gevonden, maar die voegt de records samen. Dit mag alleen als de bepalingsocde hetzelfde, anders moet de record gewoon blijven staan.

Sub combduprows() 
    Dim nr As Long, nc As Integer, fcol As Integer 
    Dim b, c() 
    Dim i As Integer, x, k As Long, j As Integer 
    With Cells(1).CurrentRegion 
        nr = .Rows.Count 
        nc = .Columns.Count 
        fcol = .Resize(1).Find("Lname").Column 
        b = .Value 
    End With 
    Redim c(1 To nr, 1 To nc) 
    With CreateObject("scripting.dictionary") 
        .comparemode = 1 
        For i = 1 To nr 
            x = b(i, fcol) 
            If Not .exists(x) Then 
                k = k + 1 
                .Add x, i 
                For j = 1 To nc 
                    c(k, j) = b(i, j) 
                Next j 
            Else 
                For j = 1 To nc 
                    If Not j = fcol Then 
                        If Not b(.Item(x), j) = b(i, j) Then 
                            If Not IsEmpty(b(i, j)) Then 
                                c(k, j) = c(k, j) & " & " & b(i, j) 
                                Cells(i, nc + 2 + j) = b(i, j) 
                            End If 
                        End If 
                    End If 
                Next j 
            End If 
        Next i 
    End With 
    With Sheets.Add 
        .Name = "Outcome" 
        .Cells(1).Resize(k, nc) = c 
    End With 
End Sub

 

[snb]

Gebruik svp code tags !

 

[cow18]

en met de macro in een voorbeeldbestandje gaat het zoeken ook beter.

 

[Klikmaar]

Het bestandje zet ik niet online vanwege privacy.

 

[cow18]

tja, je kan ook een afkooksel zonder privacy-gevoelige dingen posten.
Van je beschrijving bovenin kan ik anders niet zoveel maken.
Een gewoon voorbeeldje en het gewenste eindresultaat is toch snel gemaakt.

 

[Klikmaar]

Hierbij een fictieve excelsheet met het uiteindelijke resultaat erbij.

 

[cow18]

zie bijlage
er wordt gekopieerd van de tabel in blad1 naar de tabel in blad2

 

[Klikmaar]

Deze Macro werkt perfect. Dank daarvoor.
Nu dacht ik snel een draaitabel te maken, maar normaal doe ik dit met Office 2003 en het excelsheet open ik in een Access db, maar vanwege datum_tijd werkt het niet.
Wat ik wil is per Testcode een aparte kolom met daarin de samengevoegde tekst van die testcode erin.
ik werk sinds kort met Office 2010.