hoe loop van maken

Status
Niet open voor verdere reacties.
D

deschrik

Gebruiker
Lid geworden
2 okt 2007
Berichten
122
Ik heb een code geschreven, echter moet ik dit voor 30 werknemers doen. Weet iemand hoe ik een snelle loop kan maken? Hij moet nu namelijk heel lang nadenken voordat ie alles heeft weggeschreven:

Code: 
If Sheets(WsWerknemers).Range("B3") = "In dienst" And Sheets(WsInvoerblad).Range("C7") <> "" Then
    Sheets(WsInvoerblad).Unprotect
    Sheets(WsInvoerblad).Range("B7:H7").Copy
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues
   
    Worksheets(WsWerknemer1).Range("A8:H502").Borders.LineStyle = xlNone

Sheets(WsWerknemer1).Activate
''Application.ScreenUpdating = False
''Worksheets(WsWerknemer1).Rows("1:3").EntireRow.Hidden = Sheets("1").Range("D3") > 0

Dim rBereik As Range
Dim dTarief As Double
    dTarief = Worksheets(WsWerknemers).Range("D3").Value
    For Each rBereik In Worksheets(WsWerknemer1).Range("B9:B502")
        If rBereik.Value <> "" Then
            With Worksheets(WsWerknemers).Range("E2:AA2")
               Set Apotheek = .Find(rBereik.Value, LookIn:=xlValues, lookat:=xlWhole)
          If Not Apotheek Is Nothing Then
                   Worksheets(WsWerknemer1).Range("H" & rBereik.Row).Value = Worksheets(WsWerknemers).Cells(3, Apotheek.Column) * dTarief
                End If
            End With
       End If
    Next
    
    Worksheets(WsWerknemer1).Range("A8:H502").Sort Key1:=Worksheets(WsWerknemer1).Range("A8"), Order1:=xlAscending, Key2:=Worksheets(WsWerknemer1).Range("B8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Else
    End If
    
    If Sheets(WsWerknemers).Range("B4") = "In dienst" And Sheets(WsInvoerblad).Range("C8") <> "" Then
    Sheets(WsInvoerblad).Unprotect
    Sheets(WsInvoerblad).Range("B8:H8").Copy
    iSchrijfRij = Sheets(WsWerknemer2).Range("A502").End(xlUp).Row + 1
   Sheets("2").AutoFilterMode = False
    Sheets(WsWerknemer2).Rows(iSchrijfRij).PasteSpecial xlValues
    
    Worksheets(WsWerknemer2).Range("A8:H502").Borders.LineStyle = xlNone
   
Sheets(WsWerknemer2).Activate
''Application.ScreenUpdating = False
''Worksheets(WsWerknemer2).Rows("1:3").EntireRow.Hidden = Sheets("2").Range("D3") > 0

    dTarief = Worksheets(WsWerknemers).Range("D4").Value
    For Each rBereik In Worksheets(WsWerknemer2).Range("B9:B502")
        If rBereik.Value <> "" Then
            With Worksheets(WsWerknemers).Range("E2:AA2")
               Set Apotheek = .Find(rBereik.Value, LookIn:=xlValues, lookat:=xlWhole)
          If Not Apotheek Is Nothing Then
                   Worksheets(WsWerknemer2).Range("H" & rBereik.Row).Value = Worksheets(WsWerknemers).Cells(4, Apotheek.Column) * dTarief
                End If
            End With
       End If
    Next
    
    Worksheets(WsWerknemer2).Range("A8:H502").Sort Key1:=Worksheets(WsWerknemer2).Range("A8"), Order1:=xlAscending, Key2:=Worksheets(WsWerknemer2).Range("B8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Else
    End If
 
Hoi,

Als deze code te lang duurt denk ik dat je de code het best kunt beginnen met.

Code: 
Application.Calculation = xlManual

Als je code klaar is weer aan zetten.
Je loop neem aan dat je die wel weet daar je al een For Each hebt.

Code: 
Do
  Je code
Loop Until blabla = ""

Code: 
For i = 1 to 30
   Je code
Next i

Gr,
Alex,
 
Bedankt, kom er echter nog niet echt uit.

Ik moet dus doen, loop until i = 30?
For i = 1 to 30
Next i
 
Hoi,

Dat zijn twee voorbeelde van een loop.
Welke code wil je 30 keer doen?
Alles wat je getypt hebt? dan boven aan de For en onder aan de Next.

Gr,
Alex,
 
Ik wil de volgende code 30 keer doen:
Code: 
If Sheets(WsWerknemers).Range("B3") = "In dienst" And Sheets(WsInvoerblad).Range("C7") <> "" Then
    Sheets(WsInvoerblad).Unprotect
    Sheets(WsInvoerblad).Range("B7:H7").Copy
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues
   
    Worksheets(WsWerknemer1).Range("A8:H502").Borders.LineStyle = xlNone

Sheets(WsWerknemer1).Activate
''Application.ScreenUpdating = False
''Worksheets(WsWerknemer1).Rows("1:3").EntireRow.Hidden = Sheets("1").Range("D3") > 0

Dim rBereik As Range
Dim dTarief As Double
    dTarief = Worksheets(WsWerknemers).Range("D3").Value
    For Each rBereik In Worksheets(WsWerknemer1).Range("B9:B502")
        If rBereik.Value <> "" Then
            With Worksheets(WsWerknemers).Range("E2:AA2")
               Set Apotheek = .Find(rBereik.Value, LookIn:=xlValues, lookat:=xlWhole)
          If Not Apotheek Is Nothing Then
                   Worksheets(WsWerknemer1).Range("H" & rBereik.Row).Value = Worksheets(WsWerknemers).Cells(3, Apotheek.Column) * dTarief
                End If
            End With
       End If
    Next
    
    Worksheets(WsWerknemer1).Range("A8:H502").Sort Key1:=Worksheets(WsWerknemer1).Range("A8"), Order1:=xlAscending, Key2:=Worksheets(WsWerknemer1).Range("B8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Else
    End If
 
Ok dan doe je dat toch met de For Next.

Code: 
For i = 1 To 30
If Sheets(WsWerknemers).Range("B3") = "In dienst" And Sheets(WsInvoerblad).Range("C7") <> "" Then
    Sheets(WsInvoerblad).Unprotect
    Sheets(WsInvoerblad).Range("B7:H7").Copy
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues
   
    Worksheets(WsWerknemer1).Range("A8:H502").Borders.LineStyle = xlNone

Sheets(WsWerknemer1).Activate
''Application.ScreenUpdating = False
''Worksheets(WsWerknemer1).Rows("1:3").EntireRow.Hidden = Sheets("1").Range("D3") > 0

Dim rBereik As Range
Dim dTarief As Double
    dTarief = Worksheets(WsWerknemers).Range("D3").Value
    For Each rBereik In Worksheets(WsWerknemer1).Range("B9:B502")
        If rBereik.Value <> "" Then
            With Worksheets(WsWerknemers).Range("E2:AA2")
               Set Apotheek = .Find(rBereik.Value, LookIn:=xlValues, lookat:=xlWhole)
          If Not Apotheek Is Nothing Then
                   Worksheets(WsWerknemer1).Range("H" & rBereik.Row).Value = Worksheets(WsWerknemers).Cells(3, Apotheek.Column) * dTarief
                End If
            End With
       End If
    Next
    
    Worksheets(WsWerknemer1).Range("A8:H502").Sort Key1:=Worksheets(WsWerknemer1).Range("A8"), Order1:=xlAscending, Key2:=Worksheets(WsWerknemer1).Range("B8"), Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Else
    End If
Next i

Gr,
Alex,
 
Ok, bedankt!
Moet ik trouwens niet nog aangeven als eerste waarvoor i staat?
Zoals dim i as string
i=werknemer? zoiets?
 
Dan moet ik alleen nog ff oplossing vinden zodat ook de onderstaande waarden heletijd met 1 worden opgehoogd: B3 en C7

Code: 
If Sheets(WsWerknemers).Range("B3") = "In dienst" And Sheets(WsInvoerblad).Range("C7") <> ""

En dat range B7:H7 wordt verhoogd met +1, en dat sheets (wswerknemer1) wordt verhoogd met +1 (t/m30)

Code: 
Sheets(WsInvoerblad).Range("B7:H7").Copy
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues
 
kun je de zelfde teller voor gebruiken.

Code: 
If Sheets(WsWerknemers).Range("B" & i + 2) = "In dienst" And Sheets(WsInvoerblad).Range("C" & i + 6) <> ""

En

Code: 
Sheets(WsInvoerblad).Range("B" & i + 6 & ":H" & i + 6).Copy
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues

Gr,
Alex,
 
En hoe los ik dit op? kom er niet echt uit
Code: 
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues

Hij moet automatisch van wswerknemer1, naar tabblad wswerknemer2 gaan etc.
 
Als ik dit doe:
Code: 
    iSchrijfRij = Sheets("i").Range("A502").End(xlUp).Row + 1
    Sheets("i").AutoFilterMode = False
    Sheets("i").Rows(iSchrijfRij).PasteSpecial xlValues

Komt er de foutmelding: het subscript valt buiten het bereik:confused:
 
Wil je het werkboek i of werkboek 1,2 , ect hebben?

Code: 
    iSchrijfRij = Sheets(i).Range("A502").End(xlUp).Row + 1
    Sheets(i).AutoFilterMode = False
    Sheets(i).Rows(iSchrijfRij).PasteSpecial xlValues

Gr,
Alex,
 
Bedankt Alex! Dit werkt inderdaad zo!
Enig probleem is nu dat hij de regels van het invoerblad niet meer kopiert naar het juiste werkblad. Hij schrijft nu namelijk niets weg met de code!

Code: 
    Sheets(WsInvoerblad).Range("B7:H7").Copy
    iSchrijfRij = Sheets(WsWerknemer1).Range("A502").End(xlUp).Row + 1
    Sheets("1").AutoFilterMode = False
    Sheets(WsWerknemer1).Rows(iSchrijfRij).PasteSpecial xlValues
   
    Worksheets(WsWerknemer1).Range("A8:H502").Borders.LineStyle = xlNone

Snap echt niet hoe het opeens kan dat hij regels niet meer wegschrijft. op zich zal die dat toch moeten doen? omdat hij elke keer een i verder gaat, dus elke keer werkblad verder?
 
Moet de code alleen in WsWerknemer1 kijken?

Of ook deze met teller?

Code: 
Sheets(WsWerknemer & i).Rows(iSchrijfRij).PasteSpecial xlValues
   
    Worksheets(WsWerknemer & i).Range("A8:H502").Borders.LineStyle = xlNone
 
wederom dank Alex! moet inderdaad met teller, zoals jou code.
Hier kan ik wel weer even mee verder knoeien!:thumb:
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan