Samenvoegen tekst die in variabele rijen is weggeschreven

[Ronnospare]

Ik zit met het volgende probleem:

Ik heb een rij met gegevens van een bepaalde klant (kolom A t/m I). De data in kolom I (commentaar veld) is op meerdere rijen in kolom I weggeschreven en de cellen voorafgaand aan kolom I (A:H) zijn dan leeg.
Ik wil de data uit kolom I samenvoegen en plaatsen in kolom J.

Omdat het gaat om 30000 rijen en de ene keer het commentaar veld (kolom I) is weggeschreven op 1 rij, dan weer op 6 rijen, of zelfs 10 rijen, kan ik geen vaste formule bedenken.
Ik had het volgende bedacht, als is dit beperkt tot het samenvoegen van maximaal 4 rijen:

=ALS(A2="";"";ALS(EN(A2<>"";A3<>"");I2;ALS(EN(A2<>"";A3="";A4<>"");TEKST.SAMENVOEGEN(I2;I3);ALS(EN(A2<>"";A3="";A4="";A5<>"");TEKST.SAMENVOEGEN(I2;I3;I4);ALS(EN(A2<>"";A3="";A4="";A5="";A6<>"");TEKST.SAMENVOEGEN(I2;I3;I4;I5);TEKST.SAMENVOEGEN(I2;I3;I4;I5))))))


Wie heeft een oplossing om dit makkelijk voor alle rijen (ongeacht de hoeveelheid weggeschreven regels) toe te passen?

 

[plongske]

Maak eens een voorbeeldbestandje

 

[Ronnospare]

Kolom J is het eindresultaat

 

[plongske]

Met een voorbeeldje wordt een Excelbestandje bedoeld.

 

[Ronnospare]

is bijgevoegd (als het goed is)

 

[Niels28]

zie bijlage

Bekijk bijlage Voorbeeldbestandje.xlsm


Niels

 

[Niels28]

of met een eenmalige macro, deze verwijdert ook de overbodige info en kolom I

Sub klacht1()
Application.ScreenUpdating = False
For Each r In Range("A:A").SpecialCells(2)
c01 = ""

If r.End(xlDown).Row < 50000 Then
For Each cl In r.Offset(, 8).Resize(r.End(xlDown).Row - r.Row)
c01 = c01 & " " & Trim(cl.Value)
r.Offset(, 9).Value = Trim(c01)
Next
Else
r.Offset(, 9).Value = Trim(r.Offset(, 8).Value)
End If
Next
    'verwijdert de lege rijen in de kolom met de gesplitste klachten
    Application.DisplayAlerts = False
    Range("A1").AutoFilter
    ActiveSheet.Range("$A$1:$J$" & Cells(Rows.Count, 9).End(xlUp).Row).AutoFilter Field:=1, Criteria1:="="
    ActiveSheet.Range("$A$2:$J$" & Cells(Rows.Count, 9).End(xlUp).Row).Delete
    Range("A1").AutoFilter
    Columns(9).Delete
End Sub

Niels

 

[VenA]

Is het een soort draaitabel die je uit een bepaald systeem krijgt?

Deze zet de gegevens in 'Blad2' bij het activeren van 'Blad2'

Private Sub Worksheet_Activate()
    ar1 = Sheets(1).Cells(1).CurrentRegion
    ReDim ar2(Sheets(1).Columns(1).SpecialCells(2).Count, 8)
    For j = 1 To UBound(ar1)
        If ar1(j, 1) <> "" Then
            For jj = 1 To 9
                ar2(jjj, jj - 1) = Trim(ar1(j, jj))
            Next jj
            jjj = jjj + 1
            Else
                ar2(jjj - 1, 8) = ar2(jjj - 1, 8) & " " & Trim(ar1(j, 9))
        End If
    Next j
    With ActiveSheet
        .Cells.ClearContents
        .Cells(1).Resize(UBound(ar2), 9) = ar2
    End With
End Sub