• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Rijen samenvoegen

Status
Niet open voor verdere reacties.
stefano

stefano

Gebruiker
Lid geworden
22 mei 2004
Berichten
865
Ik wil in een bestand rijen samenvoegen tot 1 rij. In een eerste kolom wordt een nummer weergegeven. Wanneer dit nummer gelijk is dan mogen de rijen samengevoegd worden. Soms bestaat het aantal rijen uit 1, 2 of 3 rijen.

Een voorbeeld in bijlage.

Graag een oplossing in vba of mbv formules.

dbv,

Stefano

Bekijk bijlage TPM_1.XLS
 
Zo zou het kunnen.
Code: 
Sub HSV()
  Dim cl As Variant
    With Sheets("TPM_1")
      For Each cl In .Range("A2:A17")
     If cl.Value <> cl.Offset(-1).Value Then
    cl.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1).EntireRow
   End If
  Next
 End With
End Sub
 
Maar ... bij nadere kontrole stel ik vast dat de originele rijen blijven bestaan. Het is de bedoeling dat e oorspronkelijke rijen verdwijnen en overschreven worden door de nieuwe.

Slechte info van mijnentwege, sorry.

En kan de macro dan ook voorzien dat het oorspronkelijk aantal rijen zeg maar uit 500 rijen bestaat. Ik post er eentje in bijalge.

dank,

Stefano
 

Bijlagen

Zo dan.
Code: 
Sub HSV()
  Dim cl As Range
    With Sheets("TPM_1")
      For Each cl In .Range("A2:A" & Cells.SpecialCells(xlCellTypeLastCell).Row)
     If cl.Value = cl.Offset(-1).Value Then
    cl.EntireRow.Delete
   End If
  Next cl
 End With
End Sub
 
Bij het uitvoeren van de macro verdwijnen de gegevens van de tweede lijn (bv kolom vocht ). Van 3 lijnen met hetzelfde nummer in kolom a worden er 2 samengevoegd, de analysecijfers van de tweede rij verdwijnen. Nadien moet ik de macro nog eens uitvoeren om de andere lijnen samen te voegen. En ook hier verdwijnen gegevens.

Kan je nog eens helpen aub ?

dbv,

Stefano

PS : nieuwe bijlage
 

Bijlagen

Mijn excuses.
Als je rijen verwijderd, moet dat vanaf onderen. :o
Dus bij deze een nieuwe kans.
Code: 
Sub HSV()
Application.ScreenUpdating = False
  Dim i As Integer
    With Sheets("Blad1")
      For i = .Cells(Rows.Count, 1).End(xlUp).Row To 6 Step -1
        If Cells(i, 1) = Cells(i, 1).Offset(-1).Value Then
       Cells(i, 1).EntireRow.Delete
      End If
     Next i
    End With
 Application.ScreenUpdating = True
End Sub
 
Werkt prima nu wat betreft het samenvoegen van de rijen tot 1 rij, maar de gegevens die op de tweede en/of de derde rij stonden zijn verdwenen ... en dat is de bedoeling niet.

Stefano
 
Jammer dat de giga senior niet meer reageert. Bij deze dan nog eens het topic omhoog plaatsen :confused:
 
Zal een 'gewone' senior dan maar reageren? :D:D:D

Ik vond je vraag wel intrigerend dus probeer dit blokje maar 'ns uit en verbaas je...
Code: 
Sub RegelsSamenvoegen()
'Door Leo Meijer; Worksheet.NL; 29/05/2011
Dim i As Long, x As Long
Dim ii As Integer
Dim T1 As Variant
Const lSC As Long = 6  'regelnummer van de startcel

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

Groet, Leo
 
Laatst bewerkt door een moderator:
Blijkbaar was er al een andere sheet gepost.
Ik had wat zitten vogelen met sheet1 maar dat is niet meer nodig :P

Succes met de oplossing hierboven
 
Ja da's waar, maar ik raak er niet uit. Om duidelijk te proberen zijn heb ik bepaalde zaken weg gelaten om het voorbeeld makkelijk te maken, maar hiermee heb ik mezelf ( en mijn beperkte kennis ) niet verder vooruit geholpen. Bij deze 2 bestanden : 1ste is het exportbestand, 2de is wat ik het graag zou zien worden.

Dank alvast voor de hulp,

Stefano

PS : ik ga dit op het werk gebruiken en ben dagelijks met andere sheets bezig, vandaar dat het 's avonds wel es oeilijk is om nog eens achter de pc te kruipen :d:d:d
 

Bijlagen

stefano zei:
2de is wat ik het graag zou zien worden.
Klik om te vergroten...

...had je uberhaupt m'n code uitgeprobeerd (al was 't maar op je voorbeeldbijlage)???

Ma goe... Probeer deze maar 'ns uit...
Code: 
Sub RegelsSamenvoegen()
'Door Leo Meijer; Worksheet.NL; 29/05/2011
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), 38)
    ReDim T2(1 To 38, 1 To 1)
    
    For i = 1 To 38
        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 38
                If Replace(T1(i, ii), " ", "") <> "" Then T2(ii, x) = T1(i, ii)
            Next ii
        Else
            x = x + 1
            ReDim Preserve T2(1 To 38, 1 To x)
            For ii = 1 To 38
                T2(ii, x) = T1(i, ii)
            Next ii
        End If
    Next i
    
    With Sheets.Add(after:=Sheets(ActiveSheet.Index))
        With .Previous
            .Range("A1:AL1").Copy Cells(1, 1)
            .Cells.Copy
        End With
        .Cells.PasteSpecial xlPasteFormats
        .Cells(2, 1).Resize(UBound(T2, 2), 38) = WorksheetFunction.Transpose(T2)
        .Cells(1, 1).Select
    End With
    
    Application.CutCopyMode = False
    
End Sub

Groet, Leo
 
Laatst bewerkt:
Hoi Leo,

Werkt mijn insziens prima. Vandaag heb ik ook vrij vandaar dat ik een beetje meer tijd aan ... het werk ... kan besteden :confused:. Nog 1 zaak op dit moment. De data worden gekopieerd naar een nieuw tabblad. Kan je in de code voorzien dat dit gekopieerd wordt naar een tabblad met bv. de naam 'Leo' ?

dank bij voorbaat,

Stefano

ps Leo, wat is een TS ?
 
Laatst bewerkt:
Is die tab 'Leo' dan een bestaande tab of moet die nieuw gecreëerde tab de naam 'Leo' krijgen? Als het de eerste optie is, moet ik de naam weten van de tab waar de brondata op staat.

Groet, Leo

P.s. 'TS' staat voor 'Topic Starter', of wel in dit geval... JIJ! ;)
 
Neen, dat is geen bestaande tab. Dit is de tab die jij met je code creeerde en die nu Blad1 heet.

Groeten,

de TS :p
 
Dan wordt 't iets uitgebreider omdat je ook nog moet testen of de opgegeven naam al bestaat (anders klapt de boel)...
Code: 
Sub RegelsSamenvoegen()
'Door Leo Meijer; Worksheet.NL; 29/05/2011
Dim i As Long, x As Long
Dim ii As Integer
Dim sNaam As String
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), 38)
    ReDim T2(1 To 38, 1 To 1)
    
    For i = 1 To 38
        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 38
                If Replace(T1(i, ii), " ", "") <> "" Then T2(ii, x) = T1(i, ii)
            Next ii
        Else
            x = x + 1
            ReDim Preserve T2(1 To 38, 1 To x)
            For ii = 1 To 38
                T2(ii, x) = T1(i, ii)
            Next ii
        End If
    Next i
    
    With Sheets.Add(after:=Sheets(ActiveSheet.Index))
        sNaam = Application.InputBox("Geef een geldige sheetnaam...", "Naam", "nieuwe naam", , , , , 2)
        If TestNaam(sNaam) = True Then 'naam bestaat niet, dus is te gebruiken
            .Name = sNaam
        End If
        With .Previous
            .Range("A1:AL1").Copy Cells(1, 1)
            .Cells.Copy
        End With
        .Cells.PasteSpecial xlPasteFormats
        .Cells(2, 1).Resize(UBound(T2, 2), 38) = WorksheetFunction.Transpose(T2)
        .Cells(1, 1).Select
    End With
    
    Application.CutCopyMode = False
    
End Sub

Function TestNaam(TabNaam As String) As Boolean
Dim ws As Worksheet
    
    On Error Resume Next
    Set ws = Sheets(TabNaam)
    On Error GoTo 0
    If ws Is Nothing Then
        TestNaam = True
    Else
        TestNaam = False
    End If

End Function

Groet, Leo
 
Schitterend Leo, het werkt ondetussen prima ( even testen op verschillende combinaties ).
Mooie code kerel.

hartelijk dank ! ! ! :thumb::thumb::thumb:
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan