Code omzetten in lus

[deschrik]

Ik wil graag een lus krijgen voor de volgende code. Als een bepaalde cel de waarde heeft 'In dienst'dan moet hij een regel kopieren naar een apart werkblad. In de onderstaande code duurt het erg lang voordat de code is uitgevoerd, deze code komt namelijk 20 keer onder elkaar voor. Weet iemand hoe dit sneller kan mbv bijv. een lus?

If Sheets("Blad4").Range("B3") = "In dienst" Then
    iSchrijfRij = Sheets("Blad2").Range("A502").End(xlUp).Row + 1
    Sheets("Blad1").Range("B7:H7").Copy
        
    Sheets("Blad2").Activate
    Sheets("Blad2").Rows(iSchrijfRij).PasteSpecial xlValues
    Sheets("Blad2").Range("A8:H502").Select
    
     With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Application.GoTo Sheets("Blad2").Range("A1"), True

    Worksheets("Blad2").Range("A8:H502").Select
    Selection.Sort Key1:=Worksheets("Blad2").Range("A8"), Order1:=xlAscending, Key2:=Worksheets("Blad2").Range("B8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End If
    
    If Sheets("Blad4").Range("B4") = "In dienst" Then
    iSchrijfRij = Sheets("Blad3").Range("A502").End(xlUp).Row + 1
       Sheets("Blad1").Range("B8:H8").Copy
        
    Sheets("Blad3").Activate
    Sheets("Blad3").Rows(iSchrijfRij).PasteSpecial xlValues
    Sheets("Blad3").Range("A8:H502").Select
    
     With Selection.Interior
        .Pattern = xlNone
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Application.GoTo Sheets("Blad3").Range("A1"), True

    Worksheets("Blad3").Range("A8:H502").Select
    Selection.Sort Key1:=Worksheets("Blad3").Range("A8"), Order1:=xlAscending, Key2:=Worksheets("Blad3").Range("B8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    End If

 

[Wigi]

ongeteste code

Sub lusje()

[B]    Dim rLus As Range

    For Each rLus In Sheets("Blad4").Range("B3:B4")[/B]

        If rLus.Value = "In dienst" Then
            iSchrijfRij = Sheets("Blad2").Range("A502").End(xlUp).Row + 1
            Sheets("Blad1").Range("B7:H7").Copy

            Sheets("Blad2").Activate
            Sheets("Blad2").Rows(iSchrijfRij).PasteSpecial xlValues
            Sheets("Blad2").Range("A8:H502").Select

            With rLus.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            
            rLus.Borders(xlDiagonalDown).LineStyle = xlNone
            rLus.Borders(xlDiagonalUp).LineStyle = xlNone
            rLus.Borders(xlEdgeLeft).LineStyle = xlNone
            rLus.Borders(xlEdgeTop).LineStyle = xlNone
            rLus.Borders(xlEdgeBottom).LineStyle = xlNone
            rLus.Borders(xlEdgeRight).LineStyle = xlNone
            rLus.Borders(xlInsideVertical).LineStyle = xlNone
            rLus.Borders(xlInsideHorizontal).LineStyle = xlNone
            Application.GoTo Sheets("Blad2").Range("A1"), True

            Worksheets("Blad2").Range("A8:H502").Sort _
                Key1:=Worksheets("Blad2").Range("A8"), Order1:=xlAscending, _
                Key2:=Worksheets("Blad2").Range("B8"), Order2:=xlAscending, _
                Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        End If
[B]    Next rLus[/B]

End Sub

Wigi

 

[snb]

1. gebruik VBA niet voor opmaakdoeleinden
2. maak een selectie (autofiter) voor de records die in aanmerking komen gekopieerd te worden
3. voer een sortering pas uit nadat de kopieeraktie heeft plaatsgevonden
4. gebruik Goto nooit in VBA (hooguit als laatste regel van een macro)
5. zorg dat er een cel is met de opmaakkenmerken die je aan een heel gebied wil geven. Met 1 kopieer pastespecial.format aktie wordt het gebied opgemaakt.

 

[deschrik]

Wigi, bedankt! Ik ga er mee aan de slag!:thumb:

Alleen vraag ik me zo op het eerste moment af of met uw code wel regel 8 word gekopierd naar blad 3, regel 9 naar blad 4, regel 10 naar blad 5 etc.
Ik denk namelijk dat alleen regel 7 nu wordt gekopierd naar blad 2 en verder niets word gedaan met de overige regels van blad1? Of zie ik dit verkeerd?

 

[Wigi]

Ik heb enkel de lus gemaakt, de rest laat ik aan jou over

 

[deschrik]

Oke.

Krijg je dan onderaan de lus een regel:

Blad2 + 1 ?

 

[Wigi]

Als je door de sheets wil gaan, zou ik de index van een sheet gebruiken. De index kan je bvb. zo opvragen:

iBladIndex = Sheets("Blad2").Index

en daarna bvb.

Sheets(iBladIndex + 1).Range("A1").Value = "bla bla"
Sheets(iBladIndex + 2).Range("A1").Value = "bla bla"
Sheets(iBladIndex + 3).Range("A1").Value = "bla bla"
...

Wigi

 

[deschrik]

Dus de code wordt als volgt:?

Sub lusje()

    Dim rLus As Range

    For Each rLus In Sheets("Blad4").Range("B3:B4")

        If rLus.Value = "In dienst" Then
            iSchrijfRij = Sheets("Blad2").Range("A502").End(xlUp).Row + 1
            Sheets("Blad1").Range("B7:H7").Copy

            Sheets("Blad2").Activate
            Sheets("Blad2").Rows(iSchrijfRij).PasteSpecial xlValues
            Sheets("Blad2").Range("A8:H502").Select

            With rLus.Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            
            rLus.Borders(xlDiagonalDown).LineStyle = xlNone
            rLus.Borders(xlDiagonalUp).LineStyle = xlNone
            rLus.Borders(xlEdgeLeft).LineStyle = xlNone
            rLus.Borders(xlEdgeTop).LineStyle = xlNone
            rLus.Borders(xlEdgeBottom).LineStyle = xlNone
            rLus.Borders(xlEdgeRight).LineStyle = xlNone
            rLus.Borders(xlInsideVertical).LineStyle = xlNone
            rLus.Borders(xlInsideHorizontal).LineStyle = xlNone
            Application.GoTo Sheets("Blad2").Range("A1"), True

            Worksheets("Blad2").Range("A8:H502").Sort _
                Key1:=Worksheets("Blad2").Range("A8"), Order1:=xlAscending, _
                Key2:=Worksheets("Blad2").Range("B8"), Order2:=xlAscending, _
                Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        End If

iBladIndex = Sheets("Blad2")
IndexSheets(iBladIndex + 1)


    Next rLus

End Sub

 

[Wigi]

Dat gaat echt niet werken hoor. Sowieso ga je syntax errors krijgen, waardoor je zelf al weet dat dit niet gaat werken.

Op basis van de code die jij gegeven hebt, vermoed ik dat je een variabele moet vullen met een index van een blad. Dat doe je buiten de lus. Bvb. iBladIndex in mijn code hierboven.

Vervolgens, bij het wegschrijven van data, dus BINNEN de lus, ga je telkens wat bijtellen bij die index. Dat denk ik dat jouw bedoeling is, maar echt zeker ben ik niet

Wigi

 

[deschrik]

Jaa helemaal juist. Regel 7 moet worden gekopierd naar blad 2, regel 8 naar blad 3, regel 9 naar blad 4 etc.

 

[Wigi]

Jaa helemaal juist. Regel 7 moet worden gekopierd naar blad 2, regel 8 naar blad 3, regel 9 naar blad 4 etc.

Dan was mijn vermoeden juist en heb ik je goed op weg gezet