Rijen samenvoegen

[stefano]

Beste,

Ik wil van een bestand de rijen samenvoegen op voorwaarde dat die rijen in de eerste kolom A hetzelfde getal hebben staan.

De eerste rij bevat de kolomhoofdingen.

Als cel A2 en cel A3 identiek zijn, dan mogen die 2 rijen samengevoegd worden tot 1 rij.
Als cel A2 en cel A3 en cel A4 gelijk zijn, dan mogen die 3 rijen samengevoegd worden tot 1 rij.
Als cel A2 verschilt van cel A3 dan mag de rij behouden blijven.

Ik heb dit topic al eens gepost vorig jaar en de oplossing van Ginger werkt perfect. Alleen is toen uitgegaan dat er ALTIJD 3 opeenvolgende rijen met dezelfde inhoud bestonden in kolom A. Ondertussen kan het gebeuren dat dit niet altijd het geval is.

Het bestaande bestand ( zie bijlage TPM_1.xls ) mag overschreven worden door de nieuwe samengevoegde data.Bekijk bijlage TPM_1.XLS

De code die Ginger toen postte ( en waar ik dus geen jota van begrijp ) vermeld ik hieronder:

Dim i As Long, x As Long
Dim ii As Integer
Dim T1 As Variant
Const lSC As Long = 2  'regelnummer van de startcel

    T1 = Cells(lSC, 1).Resize(Cells(Rows.Count, 1).End(xlUp).Row - (lSC - 1), 140)
    ReDim T2(1 To 140, 1 To 1)
    
    For i = 1 To 140
        T2(i, 1) = T1(1, i)
    Next i
    
    x = 1
    
    For i = 2 To UBound(T1, 1)
        If T1(i, 1) = T1(i - 1, 1) Then
            For ii = 1 To 140
                If Replace(T1(i, ii), " ", "") <> "" Then T2(ii, x) = T1(i, ii)
            Next ii
        Else
            x = x + 1
            ReDim Preserve T2(1 To 140, 1 To x)
            For ii = 1 To 140
                T2(ii, x) = T1(i, ii)
            Next ii
        End If
    Next i
    
    With Sheets.Add(after:=Sheets(ActiveSheet.Index))
        With .Previous
            .Range("A1:EP1").Copy Cells(1, 1)
            .Cells.Copy
        End With
        .Cells.PasteSpecial xlPasteFormats
        .Cells(2, 1).Resize(UBound(T2, 2), 140) = WorksheetFunction.Transpose(T2)
        .Cells(1, 1).Select
    End With
  
    Application.CutCopyMode = False

 

[HSV]

Bedoel je zoiets?

Sub hsv()
Dim i As Long, y As Long, rng As Long, m As Long
 rng = Cells(Rows.Count, 1).End(xlUp).Row
   For i = 2 To rng
     y = i + 1
      m = 0
Do Until Cells(i, 1) <> Cells(y, 1)
 If rng <= i Or Cells(i, 1) = "" Then
    m = m + 1
  Rows(i).Group
Exit Do
    End If
    y = y + 1
    m = m + 1
Loop
 If m <> 0 Then
   Rows(i).Resize(m).Group
 End If
   i = y - 1
 Next i
End Sub

Om ze weg te halen.

Sub hsv_2()
 Cells.ClearOutline
End Sub

 

[stefano]

Ai , ai , neen, dat is het niet, want de gegevens van elke rij moeten samengevoegd worden. Met jouw code verdwijnen de gegevens die in rij 1 en 2 staan terwijl eigenlijk alle gegevens van rij 1, 2 en 3 in één en dezelfde rij zouden moeten komen te staan.

nr naam vocht eiwit bak
123 klant 1 15
123 klant 1 11
123 klant 1 100
456 klant 2 13
456 klant 2 11

zou moeten worden

nr naam vocht eiwit bak
123 klant 1 15 11 100
456 klant 2 13 11

hopelijk zie je dit te doen

 

[HSV]

Test het eens Stefano.

Sub HSV()
 Dim n As Long, old As Variant, tel1 As Long, i As Long, place As Variant, k As Long, code As Variant
    Range("A50").CurrentRegion.ClearContents
      Sheets(1).UsedRange.Offset(1).Sort Key1:=[A1], Key2:=[B1]
      n = Range("A2").CurrentRegion.Rows.Count - 1
   Range("A50").Resize(, 106) = Range("A1").Resize(, 106).Value
    old = "[EMAIL="!@#&$"]!@#&$[/EMAIL]"
     tel1 = 50
    For i = 1 To n
      place = Cells(i + 1, 1).Value & "|"
         If place <> old Then
           tel1 = tel1 + 1
            Cells(tel1, 1).Value = Split(place, "|")
              old = place
             k = 2
           End If
         code = Cells(i + 1, 2).Value
         If Cells(tel1, k) = "" Then
         Cells(tel1, k) = code
         Else
      Cells(tel1, k).Value = Cells(tel1, k) & ", " & code
      End If
     Cells(tel1, 3).Resize(, 104) = Cells(i, 3).Resize(, 104).Value
    Next i
End Sub

 

[stefano]

Wanneer ik de code loslaat op het bestand dan worden alle cellen met inhoud gewist.

 

[HSV]

Bij mij niet.

Het wordt bijgeschreven vanaf rij 50.

 

[stefano]

Aha, Nu zie ik het ook. Maar ik zie dat de gevens die in kolom BS staan nu niet meer verschijnen in de samengevoegde data. Kanje nog eens nakijken aub ?

dank,

Stefaan

 

[HSV]

Je wilt van elk kolom dus een samenvoeging?
Dat wordt een hele klus denk ik, nog nooit eerder gedaan.
Ik verneem het wel.