Tekst samenvoegen uit variabel aantal cellen.

[stefano]

Beste,

Van een bestand in bijlage zou tekst dienen samengevoegd te worden. Het betreft een export-bestand dat ik in deze vorm aangeboden krijg. Het aantal rijen in het bestand kan oplopen naar 100.000.

De tabel geeft in kolom A een uniek productnummer weer

Per productnummer worden een aantal ingrediënten (kolom H) weergegeven in verschillende talen (kolom G). Het aantal ingrediënten is variabel van 1 tot 19 per productnummer.

Bedoeling is deze ingrediënten samen te voegen tot 1 lijn.

……...A...……………………….G...……………..H...………………………………………...BA...………….
productnummer ….. Taalcode...…..Ingrediënten....

1000...………………….NL...……………...bloem;
1000...………………….NL...……………...gluten;
1000...………………….NL...……………...lijnzaad...…………………………….bloem;gluten;lijnzaad
1000...………………….FR...……………...farine;
1000...………………….FR...……………...gluten;
1000...………………….FR...……………...graines de lin...…………………..farine;gluten;graines de lin
1000...………………….EN...……………...flour;
1000...………………….EN...……………...gluten;
1000...………………….EN...……………...linseed………………………………...flour;gluten;linseed


Bedoeling is op de laatste rij van de productnummer - taalcode de samenvattende ingrediënten terug te vinden (kolom BA), zie rode tekst.

Kan iemand hiervoor een vba-code in elkaar knutselen?

Voor elke productnummer-taal-combinatie de ingrediënten samenvoegen naar een nieuwe kolomBekijk bijlage ZRM.xlsx

 

[edmoor]

Druk op de knop "Verzamel per taal":
Bekijk bijlage Kopie van ZRM.xlsm

 

[stefano]

Beste Ed,

Super … zoals gewoonlijk. De eerste oplossing die het geheel netjes kopieert naar een tweede tabblad was ook prima.

dank!!!

Stefaan

 

[edmoor]

Ik wist niet dat je die versie met extra tabblad al had gezien, maar deze laatste is zoals je vroeg in #1

 

[stefano]

Waarop een collega vandaag zegt : er is toch nog iets fout

Van de laatste rijen wordt de samenvoeging niet uitgevoerd. Hoe zou dit komen ?

dank,

Stefaan

 

[edmoor]

En helemaal terecht De laatste set werd wel verzameld maar niet geschreven.
Er moet nog 1 regeltje bij:

Sub CommandButton1_Click()
    prd = Cells(2, 1)
    lan = Cells(2, 7)
    Application.ScreenUpdating = False
    For i = 2 To Range("A2").CurrentRegion.Rows.Count
        If prd = Cells(i, 1) And lan = Cells(i, 7) Then
            ing = ing & Cells(i, 8)
        Else
            Cells(i - 1, 53) = ing
            prd = Cells(i, 1)
            lan = Cells(i, 7)
            ing = Cells(i, 8)
        End If
    Next i
    
    [COLOR="#FF0000"]Cells(i - 1, 53) = ing[/COLOR]
    Application.ScreenUpdating = True
End Sub

 

[stefano]

Dank je Ed.

En wat wordt het in deze code dan ?

Sub Rechthoekafgerondehoeken1_Klikken()

prd = Cells(2, 1)
lan = Cells(2, 7)

    Sheets("Blad1").Select

    For i = 2 To Range("A2").CurrentRegion.Rows.Count
        If prd = Cells(i, 1) And lan = Cells(i, 7) Then
            ing = ing & Cells(i, 8)
        Else
            With Sheets("Blad2")
                y = y + 1
                .Cells(y, 1) = prd
                .Cells(y, 2) = lan
                .Cells(y, 3) = ing
            End With
            prd = Cells(i, 1)
            lan = Cells(i, 7)
            ing = Cells(i, 8)
        End If
    Next i

    Sheets("Blad2").Select

End Sub

 

[edmoor]

Direct na het beëindigen van die verzamel loop:

Sub Rechthoekafgerondehoeken1_Klikken()

prd = Cells(2, 1)
lan = Cells(2, 7)

    Sheets("Blad1").Select

    For i = 2 To Range("A2").CurrentRegion.Rows.Count
        If prd = Cells(i, 1) And lan = Cells(i, 7) Then
            ing = ing & Cells(i, 8)
        Else
            With Sheets("Blad2")
                y = y + 1
                .Cells(y, 1) = prd
                .Cells(y, 2) = lan
                .Cells(y, 3) = ing
            End With
            prd = Cells(i, 1)
            lan = Cells(i, 7)
            ing = Cells(i, 8)
        End If
    Next i

    Sheets("Blad2").Select
    [COLOR="#FF0000"]Cells(y, 1) = prd[/COLOR]
    [COLOR="#FF0000"]Cells(y, 2) = lan[/COLOR]
    [COLOR="#FF0000"]Cells(y, 3) = ing[/COLOR]

End Sub

 

[stefano]

Ed,

OK, maar ik denk dat ik je in de fout heb gestuurd. De code waarover ik het nu heb is de eerste code die alles wegschrijft naar een tweede tabblad.

sorry.

Stefaan

 

[edmoor]

Ik zag het. Kijk nog eens naar #8.
Kan zijn dat je in het rode gedeelte y moet vervangen door y + 1
Even testen dus,

 

[stefano]

Ed,

Nu voegt hij die gegevens onderaan blad1 ipv onderaan blad2 in. ( Ik laat de macro starten vanop blad2 via een command_button).

Bekijk bijlage ZRM.xlsm

 

[edmoor]

Daarom zei ik, kijk nog eens naar #8.
Maar hier is 'ie compleet:

Sub Rechthoekafgerondehoeken1_Klikken()
    Application.ScreenUpdating = False
    prd = Cells(2, 1)
    lan = Cells(2, 7)

    Sheets("Blad1").Select

    For i = 2 To Range("A2").CurrentRegion.Rows.Count
        If prd = Cells(i, 1) And lan = Cells(i, 7) Then
            ing = ing & Cells(i, 8)
        Else
            With Sheets("Blad2")
                y = y + 1
                .Cells(y, 1) = prd
                .Cells(y, 2) = lan
                .Cells(y, 3) = ing
            End With
            prd = Cells(i, 1)
            lan = Cells(i, 7)
            ing = Cells(i, 8)
        End If
    Next i
        
    Sheets("Blad2").Select
    Cells(y, 1) = prd
    Cells(y, 2) = lan
    Cells(y, 3) = ing
    Application.ScreenUpdating = True
End Sub

 

[edmoor]

Daarom zei ik, kijk nog eens naar #8.
Maar ik heb nog wat andere aanpassingen gedaan:

Sub Rechthoekafgerondehoeken1_Klikken()
    With Sheets("Blad1")
        prd = .Cells(2, 1)
        lan = .Cells(2, 7)

        For i = 2 To .Range("A2").CurrentRegion.Rows.Count
            If prd = .Cells(i, 1) And lan = .Cells(i, 7) Then
                ing = ing & .Cells(i, 8)
            Else
                y = y + 1
                Cells(y, 1) = prd
                Cells(y, 2) = lan
                Cells(y, 3) = ing
                
                prd = .Cells(i, 1)
                lan = .Cells(i, 7)
                ing = .Cells(i, 8)
            End If
        Next i
    End With
    
    y = y + 1
    Cells(y, 1) = prd
    Cells(y, 2) = lan
    Cells(y, 3) = ing
End Sub

Bij de code voor de knop Blad wissen hoef je overigens niet eerst het blad te selecteren, daar ben je al

 

[stefano]

Dat is het, dank !

tenzij mijn collega's ….

 

[edmoor]

Haha! Dat merken we dan wel weer