Meerdere regels samenvoegen met ALT-Enter?

[totallion]

Hallo allemaal,

Ik heb weer een nieuwe uitdaging in verband met een conversie tussen 2 software pakketten.
Ik loop nu tegen het volgend probleem aan,

Ik heb een lijst met ruim 8000 artikelnummers (kolom A) met hierachter een artikelomschrijving (kolom B) en hier weer achter een per artikel wisselend aantal regels met extra informatie over dit artikel (kolom C).

De vraag,
Is het in Excel mogelijk om middels een formule o.i.d. de afzonderlijke cellen met extra artikelinformatie uit kolom C per artikelnummer samen te voegen naar 1 cel (wederom kolom C) en dan ook nog met ALT-Enter zodat de regels netjes in deze ene cel onder elkaar geplaatst worden?

Zie ook plaatje en voorbeeldbestand hieronder,

 

[VenA]

Probeer het eens met deze macro.

Sub VenA()
  ar = Sheets("Bron").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    If ar(j, 1) <> "" Then
      a = j
      c00 = ar(j, 3)
     Else
      c00 = c00 & vbCrLf & ar(j, 3)
    End If
    d(ar(a, 1) & "|" & ar(a, 2)) = c00
  Next j
  With Sheets("Resultaat").Cells(2, 10).Resize(d.Count)
    .Value = Application.Transpose(d.keys)
    .TextToColumns .Cells(1), 1, , , , , , , True, "|"
    .Offset(, 2) = Application.Transpose(d.items)
  End With
End Sub

 

[robdgr]

Met een eenvoudige formule kun je het ook oplossen:

=ALS(EN(B2<>0;B3=0);C2&TEKEN(10)&C3;"")

Zet de uitlijning op terugloop en trek deze formule naar beneden.

 

[totallion]

Hallo heren,

De macro van VenA doet helemaal waar ik naar zocht!
De formule van Rob werkt ook, echter pakt deze slechts de eerste 2 van de artikelomschrijvingen en laat de (eventueel) opvolgende regels weg?

Maar jullie hebben me hier weer een enorme dienst bewezen!
Wederom mijn dank daarvoor!

 

[VenA]

Iets korter en sneller

Sub VenA()
  ar = Sheets("Bron").Cells(1).CurrentRegion
  Set d = CreateObject("Scripting.Dictionary")
  For j = 2 To UBound(ar)
    If ar(j, 1) <> "" Then
      a = j
      c00 = ar(j, 3)
     Else
      c00 = c00 & vbCrLf & ar(j, 3)
    End If
    d(ar(a, 1) & "|" & ar(a, 2)) = Array(ar(a, 1), ar(a, 2), c00)
  Next j
  Sheets("Resultaat").Cells(2, 10).Resize(d.Count, 3) = Application.Index(d.items, 0, 0)
End Sub

 

[HSV]

Ter illustratie.

Sub hsv()
Dim sv, sv_2, s0
Sheets("bron").Cells(1).CurrentRegion.Columns(1).Offset(2).Name = "br"
   sv = Split(Join(Filter([transpose(if(offset(br,-1,)="",offset(br,-2,2),if(offset(br,-1,)<>"",offset(br,-2,2)&"|","~")))], "~", 0), vbLf), "|" & vbLf)
   s0 = Application.Transpose(Split(Join(Filter([transpose(if(offset(br,-2,)="","~",row(offset(br,-2,))))], "~", 0), "|"), "|"))
  With Sheets("resultaat")
     .Cells(1).Resize(UBound(sv) + 1, 2) = Application.Index(Sheets("bron").UsedRange.Resize(, 2), s0, Array(1, 2))
     .Cells(1, 3).Resize(UBound(sv) + 1) = Application.Transpose(sv)
  End With
End Sub