• 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.

Selecties maken en kopiëren

Status
Niet open voor verdere reacties.
J

jos0707

Gebruiker
Lid geworden
17 jun 2011
Berichten
75
Selecties maken en kopiëren

Ik krijg bestellingen binnen zoals te zien in op blad 1 van de bijlage.
Graag had ik de gegevens in de kolommen die ik gemakkelijkshalve groen gekleurd heb gekopiëerd gezien naar het “Verzamelblad” om er dan verder op blad 3 nog zaken aan toe te kunnen voegen.
En graag in deze volgorde:

Artikelnummer
Artikelnaam
Leveringsnaam
Secundaire verkoophoeveelheid
Secundaire eenheid
Hoeveelheid
Eenheid
Gevraagde ontvangstdatum
Leveringsmethode

Alvast hartelijk dank voor jullie hulp.
Groeten,
Jos
Bekijk bijlage Selecteren.xlsx
 
Een poging...
Wel geduld hebben, want hij doorloopt alle 'gebruikte' regels en kolommen in Blad1.
Hij kan nog wel wat mooier, maar goed... hij doet het volgens mij naar behoren :)
Code: 
Sub Spaarie()
    Application.ScreenUpdating = False
    With Sheets("Blad1")
        For r = 1 To .UsedRange.Rows.Count
            For k = 1 To .UsedRange.Columns.Count
                If .Cells(r, k) = "Artikelnummer" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("A" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Artikelnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("B" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Leveringsnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("C" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Secundaire verkoophoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("D" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Secundaire eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("E" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Hoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("F" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("G" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Gevraagde ontvangstdatum" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("H" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Leveringsmethode" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("I" & Rows.Count).End(xlUp).Offset(1)
            Next k
        Next r
    End With
    With Sheets("Verzamelblad")
        .Range(.Range("A" & .Range("C" & Rows.Count).End(xlUp).Offset(1).Row), .Range("I" & .Range("I" & Rows.Count).End(xlUp).Row)).ClearContents
    End With
    Application.ScreenUpdating = True
End Sub
 
Laatst bewerkt:
Jos,

zet je de status dan ook op "Opgelost"?
 
bovenaan, waar je de vraag gestart hebt.
 
Nog ff tussendoor...
Ik deed een poging om hem sneller te maken, maar liep tegen een paar onjuist heden op.

Hoop dat ie nu wat sneller is en de onjuistheden zijn eruit:
Code: 
Sub Spaarie()
    Dim rij As New Collection
    Application.ScreenUpdating = False
    With Sheets("Blad1")
        For Each c In .Range("A1:A" & .Range("A" & Rows.Count).End(xlUp).Row)
            If c = "Artikelnummer" Then rij.Add c.Row
        Next
        
        For Each r In rij
            For k = 1 To .UsedRange.Columns.Count
                If .Cells(r, k) = "Artikelnummer" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("A" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Artikelnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("B" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Leveringsnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("C" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Secundaire verkoophoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("D" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Secundaire eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("E" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Hoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("F" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("G" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Gevraagde ontvangstdatum" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("H" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Leveringsmethode" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("I" & Rows.Count).End(xlUp).Offset(1)
                
            
            Next k
            
            With Sheets("Verzamelblad")
                .Range(.Range("A" & .Range("C" & Rows.Count).End(xlUp).Offset(1).Row), .Range("I" & .UsedRange.Rows.Count)).ClearContents
            End With
            
        Next r
    End With
    Application.ScreenUpdating = True
End Sub
 
Dag Spaarie,
bedankt voor al je moeite, ik apprecier het geweldig.
Maar deze code lijkt me niet goed te lopen.
Wanneer ik mijn gegevens op blad1 uitbreid tot 2600 lijnen (dmv kopiëren en plakken) en laat dan je eerste code lopen krijg ik 1693 lijnen als resultaat, wat me correct lijkt te zijn, wanneer ik echter je laatste code laat lopen krijg ik maar 1333 lijnen wat me niet juist lijkt te zijn.
Grts,
Jos
 
Ja klopt. Ben toch nog tegen foutje gelopen.
Maar geloof me, de eerste code werkt niet juist en je krijgt foutieve info.
Volgende poging (nu denk ik correct)
Code: 
Sub Spaarie()
    Dim rij As New Collection
    Application.ScreenUpdating = False
    With Sheets("Blad1")
        For r = 1 To .UsedRange.Rows.Count
            For k = 1 To .UsedRange.Columns.Count
                If .Cells(r, k) = "Artikelnummer" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("A" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Artikelnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("B" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Leveringsnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("C" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Secundaire verkoophoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("D" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Secundaire eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("E" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Hoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("F" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("G" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Gevraagde ontvangstdatum" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("H" & Rows.Count).End(xlUp).Offset(1)
                If .Cells(r, k) = "Leveringsmethode" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("I" & Rows.Count).End(xlUp).Offset(1)
            Next k
            With Sheets("Verzamelblad")
                .Range(.Range("A" & .Range("C" & Rows.Count).End(xlUp).Offset(1).Row), .Range("I" & .UsedRange.Rows.Count)).ClearContents
            End With
        Next r
    End With
    Application.ScreenUpdating = True
End Sub
 
Bedankt, werkt goed, ik krijg 1693 lijnen, zelfde als met de oudere code.
 
Heb je de resultaten vergeleken? Deze zijn volgens mij anders...
 
Hallo Spaarie,
Het programma werkt prima alleen als ik bij de laatste klant een regel kleur wordt deze fout overgenomen. Wanneer ik hoger een regel kleur gaat alles goed.(zie bijlage)
Wat kan hiervan de oorzaak zijn?
Alvast bedankt.
Groeten,
Jos
 

Bijlagen

Aangepast
Code: 
Sub Selecteren()
    'In this workbook zit ook nog een macro die uitgevoerd wordt bij afsluiten
    Application.ScreenUpdating = False
        
    With Sheets("Blad1")
        With .Cells
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
        End With
        
        For r = 1 To .UsedRange.Rows.Count
            For k = 1 To .UsedRange.Columns.Count
                If IsNumeric(.Cells(r, k)) Or .Cells(r, k) = "" Then
                    Exit For
                Else
                    If .Cells(r, k) = "Artikelnummer" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("A" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Artikelnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("B" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Leveringsnaam" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("C" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Secundaire verkoophoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("D" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Secundaire eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("E" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Hoeveelheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("F" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Eenheid" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("G" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Gevraagde ontvangstdatum" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("H" & Rows.Count).End(xlUp).Offset(1)
                    If .Cells(r, k) = "Leveringsmethode" Then .Range(.Cells(r, k), .Cells(r, k).End(xlDown)).Offset(1).Copy Sheets("Verzamelblad").Range("I" & Rows.Count).End(xlUp).Offset(1)
                End If
            Next k
            With Sheets("Verzamelblad")
                .Range(.Range("A" & .Range("C" & Rows.Count).End(xlUp).Offset(1).Row), .Range("I" & .UsedRange.Rows.Count + 1)).Delete
            End With
        Next r
    End With
    With Application
        .Goto Sheets("Verzamelblad").Range("A2")
        .ScreenUpdating = True
    End With
    'In this workbook zit ook nog een macro die uitgevoerd wordt bij afsluiten
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan