Ggevens wegschrijven naar desbetreffende tabblad.

[danny147]

Beste,

Graag had ik de gegevens willen wegschrijven van Blad1 naar de desbetreffende tabbladen.
In kolom C staan LK nummers waar er voor sommige een tabblad van opgemaakt is.
De bedoeling is dat alle LK's met hetzelfde nummer weggeschreven wordt naar zijn eigen tabblad.
Ook zijn er nummers waar er een R achter staat, deze wil ik ook op het tabblad daar waar er geen R staat.
VB: LK100R moet in tabblad LK100 komen.

Zijn er nog vragen dan hoor ik het graag.

Groetjes Danny147. :thumb:

 

[Cobbe]

Als je nu eens een (verborgen)hulpkolom inlast achter kolom C en je zet deze dus in Kolom D:

=ALS.FOUT(ALS(LINKS(C3;2)="LK";"LK" & DEEL(C3;VERGELIJKEN(WAAR;ISGETAL(1*DEEL(C3;RIJ($1:$9);1));0);AANTAL(1*DEEL(C3;RIJ($1:$9);1)));"");"")

CTRL-SHFT-ENTER ---> matrixformule !!!

Dan heb je in elk geval al de tabbladnamen er in staan waarnaar geschreven moet worden.

Misschien komt de rest ook nog.

 

[Cobbe]

Ik heb een kleine macro voor u die geen hulpkolom behoeft.
Heb wel een nummer gezet in kolom A om het copiëren te vergemakkelijken.

Sub cobbe()
On Error Resume Next
With ActiveSheet
 For Each cl In .Range("C3:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
   If Left(cl, 2) = "LK" Then
     For i = 1 To Len(cl)
        Select Case Mid(cl, i, 1)
            Case 0 To 9
                Cijfers = Cijfers & Mid(cl, i, 1)
        End Select
    Next
   Shname = "LK" & Cijfers
    .Rows(cl.Row).EntireRow.Cut _
     Sheets(Shname).Range("A" & Sheets(Shname).Range("A" & Sheets(Shname).Rows.Count).End(xlUp).Row + 1)
   End If
   Shname = "": Cijfers = ""
 Next
End With
End Sub

 

[danny147]

Beste Cobbe

Heb de code laten lopen in mijn officieel bestandje.
Na een uurtje heb ik de lopende code onderbroken en gekeken wat hij heeft gedaan.
Hetgeen uitgevoerd is, is perfect alleen wat traag (ligt niet aan mijn laptop)
Hij heeft 1300 regels weggeschreven van de 4800 regels die er in staan.
Deze moet hij verdelen onder 314 verschillende tabbladen.

Is er geen snellere manier om dit uit te voeren?
Volgens mijn schatting gaat hij hier minstens 3uur overdoen.

Groetjes Danny :thumb:

 

[Cobbe]

Hallo, was even buiten strijd - een kleine ingreep laten doen in het ziekenhuis -
Ik zie niet direct waarom dat zò lang moet duren, een lus duurt natuurlijk lang maar +/-5000 regels is toch ook niet een geweldige hoeveelheid.

Zie je er iets in om via die hulpkolom en de formule in vorige post te gebruiken?
Dan pas ik de code aan en kun je dit eens testen.

Is dit eenmalig of komt dit vaker terug?

 

[danny147]

Beste Cobbe,

De Tabbladen zijn allemaal aangemaakt door mij via onderstaande code dmv lijst.

Sub ExtraSheets()

Dim strNaam As String
Dim i As Integer
i = 1
strNaam = Worksheets("Blad4").Cells(i, 1).Value

Do While strNaam <> ""
Worksheets.Add
ActiveSheet.Name = strNaam
i = i + 1
strNaam = Worksheets("Blad4").Cells(i, 1).Value

Loop

End Sub

Groetjes Danny :thumb:

 

[Cobbe]

Als je toch alle bladen hebt aangemaakt met de koptekst kan je in kolom A van blad1 mijn matrixformule gebruiken en de macro draaien:

Sub cobbe()
On Error Resume Next
With ActiveSheet
 For Each cl In .Range("A3:A" & .Range("C" & .Rows.Count).End(xlUp).Row)
   If Not cl = "" Then
     .Rows(cl.Row).EntireRow.Copy _
     Sheets(cl.Text).Range("A" & Sheets(cl.Text).Range("B" & Sheets(cl.Text).Rows.Count).End(xlUp).Row + 1)
   End If
 Next
End With
End Sub

Dit zou max 5 sec mogen duren.

 

[Warme bakkertje]

@Danny

Ik heb een macro gemaakt die met Autofilter 6000 regels over 19 sheets verdeelt. Dit gebeurt in 0.2 sec.
Als dit je wat lijkt laat maar iets weten en kunnen we verder bouwen op de werkelijke situatie.
Als je mijn emailadres nog hebt kan je me eventueel het origineel doorsturen om te testen.

 

[danny147]

Beste Cobbe, :thumb:

Heb de code laten lopen en het duurde ongeveer 50 sec. (valt nog mee, maar minder is beter)
Nu zijn er buiten de LK ook loopkranen die beginnen met S en 3 cijfers die ik ook zou willen.
Kan je dit in je matrixformule aanpassen?

Groetjes Danny

 

[Cobbe]

Dit s de aangepaste matrixformule:

=ALS.FOUT(ALS(LINKS(C3;2)="LK";"LK" & DEEL(C3;VERGELIJKEN(WAAR;ISGETAL(1*DEEL(C3;RIJ($1:$9);1));0);AANTAL(1*DEEL(C3;RIJ($1:$9);1)));ALS(LINKS(C3;1)="S";"S" & DEEL(C3;VERGELIJKEN(WAAR;ISGETAL(1*DEEL(C3;RIJ($1:$9);1));0);AANTAL(1*DEEL(C3;RIJ($1:$9);1)));""));"")

Succes !

 

[danny147]

Beste Cobbe,

Bedankt voor alles

Groetjes Danny. :thumb: