VBA Pas uitvoeren naar controle

Status
Niet open voor verdere reacties.
G

gpiket7

Gebruiker
Lid geworden
25 jul 2008
Berichten
169
Ik heb een stuk VBA script

Code: 
Private Sub CommandButton1_Click()
With Columns(5).SpecialCells(2, 2)
        .Offset(, 18).Formula = Replace("=$N6/Gebruikers!$G$2*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
        .Offset(, 19).Formula = Replace("=$N6/Gebruikers!$G$9*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
Dim r As Range
    For Each r In Range("A1:A100") ' Dit is de range waar de nullen kunnen staan
        If r.Value = "" Then
            r.EntireRow.Hidden = True ' Verstoppen van de rij
        Else
            r.EntireRow.Hidden = False ' Zichtbaar maken van de rij
        End If
    Next
End With
End Sub

Deze vult een formule in als de kolom E is gevuld.
Nu wil ik er graag een controle in bouwen, maar heb geen idee hoe.

Als in Kolom F de optie Dienst staat dan moet deze controleren of in kolom F de optie Dienst vaker voorkomt.
Als dit het geval is dan moet deze controleren de datums en tijden in Kolom H (begin datum)
Kolom I (begin tijd) Kolom J (eind datum) en Kolom K (eind tijd) niet overlappend zijn.
Als dit wel is mag de formule niet geplaatst worden bij de 2de dienst.
 
Laatst bewerkt:
Ik denk dat je een bestandje bij moet voegen om reacties te krijgen.
Groet, Ed
 
Zoiets?
Code: 
Sub checkit()
   With Sheets(1)
   For r = 11 To .UsedRange.Rows.Count
      If .Cells(r, 6) = "Dienst" Then t = t + 1
      If t = 2 Then
         t = 1             'reset voor de volgende 'Dienst'
         begin = FormatDateTime(.Cells(r, 8).Text & " " & .Cells(r, 9).Text & ":00")
         eind = FormatDateTime(.Cells(r, 10).Text & " " & .Cells(r, 11).Text & ":00")
         If eind > begin Then
   
            'ZET HIER DE REST VAN JE CODE
         
         End If
      End If
   Next r
   End With
End Sub
Groet, Ed
 
Heb er dit van gemaakt:

Code: 
Sub checkit()
   With Sheets(1)
   For r = 11 To .UsedRange.Rows.Count
      If .Cells(r, 6) = "Dienst" Then t = t + 1
      If t = 2 Then
         t = 1             'reset voor de volgende 'Dienst'
         begin = FormatDateTime(.Cells(r, 8).Text & " " & .Cells(r, 9).Text & ":00")
         eind = FormatDateTime(.Cells(r, 10).Text & " " & .Cells(r, 11).Text & ":00")
         If eind > begin Then
   
            Private Sub CommandButton1_Click()
With Columns(5).SpecialCells(2, 2)
        .Offset(, 18).Formula = Replace("=$N6/Gebruikers!$G$2*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
        .Offset(, 19).Formula = Replace("=$N6/Gebruikers!$G$9*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
Dim r As Range
    For Each r In Range("A1:A100") ' Dit is de range waar de nullen kunnen staan
        If r.Value = "" Then
            r.EntireRow.Hidden = True ' Verstoppen van de rij
        Else
            r.EntireRow.Hidden = False ' Zichtbaar maken van de rij
        End If
         
   Next r
   End With
End Sub

Krijg geen foutmelding, maar de formule is wel gewoon geplaatst
 
Je zet een procedure in een procedure. Da's een hele foute procedure.
 
Oké ik zie het, heb het aangepast naar:

Code: 
Private Sub CommandButton1_Click()

   With Sheets(1)
   For r = 11 To .UsedRange.Rows.Count
      If .Cells(r, 6) = "Dienst" Then t = t + 1
      If t = 2 Then
         t = 1             'reset voor de volgende 'Dienst'
         begin = FormatDateTime(.Cells(r, 8).Text & " " & .Cells(r, 9).Text & ":00")
         eind = FormatDateTime(.Cells(r, 10).Text & " " & .Cells(r, 11).Text & ":00")
         If eind > begin Then
   

With Columns(5).SpecialCells(2, 2)
        .Offset(, 18).Formula = Replace("=$N6/Gebruikers!$G$2*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
        .Offset(, 19).Formula = Replace("=$N6/Gebruikers!$G$9*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
Dim r As Range
    For Each r In Range("A1:A100") ' Dit is de range waar de nullen kunnen staan
        If r.Value = "" Then
            r.EntireRow.Hidden = True ' Verstoppen van de rij
        Else
            r.EntireRow.Hidden = False ' Zichtbaar maken van de rij
        End If
         
   Next r
   End With
End Sub

Maar krijg dan een foutmelding: Compileerfout: Dubbele declaratie in het huidige bereik...
 
I'll have to go. Ik kom er maandag wel op terug okee?
Ik zie trouwens dat ik de begin en eindtijd van dezelfde dienst zit te vergelijken, maar komt goed. Houdt moed!
 
Niet om het een of het ander maar er ontbrak nogal wat aan je code.
hierbij de aangepaste code:

Code: 
Private Sub CommandButton1_Click()
    Dim rr As Range
    With Sheets(1)
    For r = 11 To .UsedRange.Rows.Count
       If .Cells(r, 6) = "Dienst" Then t = t + 1
       If t = 2 Then
          t = 1             'reset voor de volgende 'Dienst'
          begin = FormatDateTime(.Cells(r, 8).Text & " " & .Cells(r, 9).Text & ":00")
          eind = FormatDateTime(.Cells(r, 10).Text & " " & .Cells(r, 11).Text & ":00")
          If eind > begin Then
             With Columns(5).SpecialCells(2, 2)
                 .Offset(, 18).Formula = Replace("=$N6/Gebruikers!$G$2*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
                 .Offset(, 19).Formula = Replace("=$N6/Gebruikers!$G$9*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
             End With
             For Each rr In Range("A1:A100") ' Dit is de range waar de nullen kunnen staan
                 If rr.Value = "" Then
                     rr.EntireRow.Hidden = True ' Verstoppen van de rij
                 Else
                     rr.EntireRow.Hidden = False ' Zichtbaar maken van de rij
                 End If
             Next rr
         End If
     End If
     Next r
     End With
End Sub
 
kan deels korter:
Code: 
For Each rr In Range("A1:A100") 
  rr.EntireRow.Hidden = rr.Value = ""
Next rr
of
Code: 
.[A1:A100].specialcells(4).entirerow.hidden=true
 
Laatst bewerkt:
Sorry voor de late reactie, maar had het weekend geen computer.
Ik heb het geprobeerd met de code

Code: 
Private Sub CommandButton1_Click()
    Dim rr As Range
    With Sheets(1)
    For r = 11 To .UsedRange.Rows.Count
       If .Cells(r, 6) = "Dienst" Then t = t + 1
       If t = 2 Then
          t = 1             'reset voor de volgende 'Dienst'
          begin = FormatDateTime(.Cells(r, 8).Text & " " & .Cells(r, 9).Text & ":00")
          eind = FormatDateTime(.Cells(r, 10).Text & " " & .Cells(r, 11).Text & ":00")
          If eind > begin Then
             With Columns(5).SpecialCells(2, 2)
                 .Offset(, 18).Formula = Replace("=$N6/Gebruikers!$G$2*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
                 .Offset(, 19).Formula = Replace("=$N6/Gebruikers!$G$9*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
             End With
             For Each rr In Range("A1:A100") ' Dit is de range waar de nullen kunnen staan
                 If rr.Value = "" Then
                     rr.EntireRow.Hidden = True ' Verstoppen van de rij
                 Else
                     rr.EntireRow.Hidden = False ' Zichtbaar maken van de rij
                 End If
             Next rr
         End If
     End If
     Next r
     End With
End Sub

Maar hij plaatst de formule nog steeds
 
Zoals ik al zei: begin- en eindtijd van dezelfde dienst werden vergeleken.

Vervang deze regel:
eind = FormatDateTime(.Cells(r, 10).Text & " " & .Cells(r, 11).Text & ":00")
door:
eind = FormatDateTime(.Cells(r - 1, 10).Text & " " & .Cells(r - 1, 11).Text & ":00")

Groet, Ed
 
Ik zat op blad UMG en jij moet blad ZuidWest hebben zie ik nu aan de formule die je erin wilt hebben.
Dat kwam omdat er 2x CommandButton1 bestaat. Maar goed, zo moet het lukken.

Code: 
Sub CommandButton1_Click()
   Dim rr As Range
   With Sheets("[COLOR="Red"]Zuid West[/COLOR]")
      For r =[COLOR="red"] 73 [/COLOR]To 100 '.UsedRange.Rows.Count
         If .Cells(r, 6) = "Dienst" Then t = t + 1
         If t = 2 Then        'je zit nu bij de 2e 'Dienst'
            begin = FormatDateTime(.Cells(r, 8).Text & " " & .Cells(r, 9).Text & ":00")
            eind = FormatDateTime(.Cells(r - 1, 10).Text & " " & .Cells(r - 1, 11).Text & ":00")
            If eind < begin Then
            
               With Columns(5).SpecialCells(2, 2)
                  .Offset(, 18).Formula = Replace("=$N6/Gebruikers!$G$2*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
                  .Offset(, 19).Formula = Replace("=$N6/Gebruikers!$G$9*IF($E6=#Alle Vestigingen incl. SBC#,Gebruikers!$G$2,IF($E6=#Alle Vestigingen excl. SBC#,Gebruikers!$I$2,IF($E6=#Alle SBC Vestigingen#,Gebruikers!$H$2,IF($E6=#Alle Vestigingen#,Gebruikers!$I$2,VLOOKUP($E6,Gebruikers!$A$2:$C$60,3,0)))))", "#", Chr(34))
                  For Each rr In Range("A1:A100") ' Dit is de range waar de nullen kunnen staan
                     If rr.Value = "" Then
                        rr.EntireRow.Hidden = True ' Verstoppen van de rij
                     Else
                        rr.EntireRow.Hidden = False ' Zichtbaar maken van de rij
                     End If
                  Next
               End With
               
            End If
            t = 1  'reset voor de volgende 'Dienst'
         End If
      Next r
   End With
End Sub
Probeer gewoon mijn stukje code goed te doorgronden, dan kom je er makkelijk zelf uit als ik zo naar je programmeerkunsten kijk.
Groet, Ed
 
Laatst bewerkt:
Code: 
Sub checkdienst()
   sq= Sheets(1).UsedRange
   for j=12 to ubound(sq)
     If TimeValue(sq(j - 1, 10) & ":" & sq(j - 1, 11)) >= TimeValue(sq(j, 8) & ":" & sq(j, 9)) Then MsgBox "Overlappend"
   Next
End Sub
 
Hoi snb,
Jij zit ook al in Sheets("UMG") zie ik, hahaha.
Groet, Ed
 
Je hebt me al een eind op weg geholpen.
Hij plaatst nu alleen helemaal geen formule meer.
 
Omdat in Sheets("Zuid West").[J73] de datum [H74] overlapt.
Dat was toch je bedoeling?
Als je H74 wijzigt in 8-12-2009 is er geen overlap en worden je formules wel geplaatst.
 
De 'With Columns(5).SpecialCells(2, 2)' -constructie moet dan omgezet worden in een For Next constructie oid. omdat er nu niet tussen te komen is.
Vraag 1: moet alles boven regel 73 sowieso wél de formule krijgen?
Vraag 2: kunnen er meer dan twee 'Dienst'regels voorkomen? Zo ja: welke moeten er dan vergeleken worden?
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan