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

kleine aanpassing wie kan me helpen

Status
Niet open voor verdere reacties.
L

lsc.b

Gebruiker
Lid geworden
4 nov 2000
Berichten
314
ik heb de onderstaande code ,
aangepast voor zover alles goed.
maar nu wil ik een 3 tal cellen die verplicht ingevuld moeten zijn
maar ik weet mu nu geen raad, het gaat om de cellen u2 u3 en t9
als ik me niet vergis moet het hier ergen bij komen te staan.

For i = 5 To 15
If Range("j" & i) > 0 And Range("k" & i) = "" Then Fout = Fout + 1 'Meer dan tijden dan activiteiten
If Range("j" & i) = "" And Range("k" & i) <> "" Then Fout = Fout + 1 'Meer activiteiten dan tijden
Next i
If Fout > 0 Then
Range("J5").Select
MsgBox "Er ontbreekt een activiteit of een tijdstip.", _
vbCritical, "Tijdstip en activiteit" 'is aantal tijden en activiteiten niet gelijk, dan melden
End 'stoppen

hier onder is de volledige code

Sub Overbrengen()
Sheets("Uren").Select
If [D2] = "" Then
Range("D2").Select
MsgBox "U moet uw naam nog invullen.", vbCritical, "Wat is uw naam?"
End 'stoppen
End If
If [D4] = "" Then
Range("D4").Select
MsgBox "U moet nog een datum invullen.", vbCritical, "Welke datum?"
End 'stoppen
End If
For i = 5 To 15
If Range("j" & i) > 0 And Range("k" & i) = "" Then Fout = Fout + 1 'Meer dan tijden dan activiteiten
If Range("j" & i) = "" And Range("k" & i) <> "" Then Fout = Fout + 1 'Meer activiteiten dan tijden
Next i
If Fout > 0 Then
Range("J5").Select
MsgBox "Er ontbreekt een activiteit of een tijdstip.", _
vbCritical, "Tijdstip en activiteit" 'is aantal tijden en activiteiten niet gelijk, dan melden
End 'stoppen
End If
Range("A19:I19,M19:R19").Copy 'Kopieer de uren
DezeDatum = [D4].Value 'onthoud de datum in D4
Sheets("Jaar").Select 'Ga naar het andere blad
Set DatumRij = Range("B1:B400").Find(What:=DezeDatum, LookAt:=xlPart) 'zoek deze datum
If DatumRij Is Nothing Then
MsgBox "Ik kan deze datum niet vinden.", vbCritical, "Foutieve datum" 'staat de datum niet in de lijst, dan melden
End
End If
'Anders: plak de uren
Aantal = Application.WorksheetFunction.CountA(DatumRij.Offset(0, 1).Range("A1:I1")) 'Relatief: 15 cellen in kolom B naast de datum
If Aantal > 0 Then 'Als er al uren staan bij die datum, geef dan melding:
DatumRij.Offset(0, 0).Range("A1:J1").Select
Beep
If MsgBox("U hebt deze dag al ingevoerd." & vbCrLf _
& "Gaat u door, dan worden de bestaande uren overschreven." & vbCrLf _
& "Weet u het zeker?", vbYesNo + vbQuestion, _
"Datum is al ingevoerd") = vbNo Then
GoTo Afronden 'Klik je op Nee, dan ga je naar Afronden
End If
End If
'Klik je op Ja, dan worden de uren geplakt
DatumRij.Offset(0, 1).PasteSpecial Paste:=xlValues 'vanaf deze cel 1 kolom naar rechts, en waarden plakken
DatumRij.Offset(0, 0).Range("A1:J1").Select
MsgBox "De uren van deze datum zijn opgeslagen.", _
vbInformation, "Klaar"
Afronden:
Sheets("Uren").Select 'Terug naar blad Uren
Range("D4").Select 'naar cel D4
Application.CutCopyMode = False 'Zet stippellijnen van het kopiëren uit
End Sub
 
Zet die code even in codetags en plaats een voorbeeld document.
 
Je bent de codetags vergeten te plaatsen dus ga het niet uitpluizen maar om je op weg te helpen.

Code: 
if application.counta([u2:u3], [t9])= 3 then msgbox "alles is ingevuld"
 
kleine aanpassing

de cellen u2,u3 en t9 moeten verplicht ingevuld zijn voor het opslaan


HTML: 
Sub LeegMaken()
    Range("J5:K15,t6,t9,u2:u3").Select
    Beep
    If MsgBox("De bestaande uren worden gewist." & vbCrLf & _
        "Weet u het zeker?", vbYesNo + vbQuestion, "Uren wissen") = _
        vbYes Then
        Range("J5:m15,t6,t9,u2:u3").ClearContents
        Range("D4").Select
    End If
End Sub

Sub GaNaarVandaag()
Dim Vandaag As Range
    Set Vandaag = Range("D1:D400"). _
        Find(What:=Date, LookAt:=xlPart)
    Vandaag.Select
End Sub

Sub Overbrengen()
    Sheets("Uren").Select
    If [D2] = "" Then
        Range("D2").Select
        MsgBox "U moet uw naam nog invullen.", vbCritical, "Wat is uw naam?"
        End 'stoppen
    End If
    If [D4] = "" Then
        Range("D4").Select
        MsgBox "U moet nog een datum invullen.", vbCritical, "Welke datum?"
        End 'stoppen
    End If
    For i = 5 To 15
        If Range("j" & i) > 0 And Range("k" & i) = "" Then Fout = Fout + 1 'Meer dan tijden dan activiteiten
        If Range("j" & i) = "" And Range("k" & i) <> "" Then Fout = Fout + 1 'Meer activiteiten dan tijden
    Next i
    If Fout > 0 Then
        Range("J5").Select
        MsgBox "Er ontbreekt een activiteit of een tijdstip.", _
            vbCritical, "Tijdstip en activiteit" 'is aantal tijden en activiteiten niet gelijk, dan melden
    If Application.CountA([u2:u3], [t9]) = 3 Then MsgBox "alles is ingevuld"
        End 'stoppen
    End If
    Range("A19:I19,M19:R19").Copy 'Kopieer de uren
    DezeDatum = [D4].Value  'onthoud de datum in D4
    Sheets("Jaar").Select 'Ga naar het andere blad
    Set DatumRij = Range("B1:B400").Find(What:=DezeDatum, LookAt:=xlPart) 'zoek deze datum
    If DatumRij Is Nothing Then
        MsgBox "Ik kan deze datum niet vinden.", vbCritical, "Foutieve datum" 'staat de datum niet in de lijst, dan melden
        End
    End If
'Anders: plak de uren
    Aantal = Application.WorksheetFunction.CountA(DatumRij.Offset(0, 1).Range("A1:I1"))  'Relatief: 15 cellen in kolom B naast de datum
    If Aantal > 0 Then 'Als er al uren staan bij die datum, geef dan melding:
        DatumRij.Offset(0, 0).Range("A1:J1").Select
        Beep
        If MsgBox("U hebt deze dag al ingevoerd." & vbCrLf _
        & "Gaat u door, dan worden de bestaande uren overschreven." & vbCrLf _
        & "Weet u het zeker?", vbYesNo + vbQuestion, _
        "Datum is al ingevoerd") = vbNo Then
        GoTo Afronden 'Klik je op Nee, dan ga je naar Afronden
        End If
    End If
'Klik je op Ja, dan worden de uren geplakt
    DatumRij.Offset(0, 1).PasteSpecial Paste:=xlValues 'vanaf deze cel 1 kolom naar rechts, en waarden plakken
    DatumRij.Offset(0, 0).Range("A1:J1").Select
    MsgBox "De uren van deze datum zijn opgeslagen.", _
    vbInformation, "Klaar"
Afronden:
    Sheets("Uren").Select 'Terug naar blad Uren
    Range("D4").Select 'naar cel D4
    Application.CutCopyMode = False 'Zet stippellijnen van het kopiëren uit
End Sub
 

Bijlagen

HSV zei:
Je bent de codetags vergeten te plaatsen dus ga het niet uitpluizen maar om je op weg te helpen.

Code: 
if application.counta([u2:u3], [t9])= 3 then msgbox "alles is ingevuld"
Klik om te vergroten...

rest mij nog de vraag waar moet ik deze regel plaatsen
 
Je vroeg "voor het opslaan".

Dan zou ik het in de Thisworkbook-module plaatsen.
Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Application.CountA([u2:u3], [t9]) <> 3 Then
 Cancel = True
 MsgBox "verplichte cellen zijn niet ingevuld,... bestand niet opgeslagen"
End If
End Sub
 
HSV zei:
Je vroeg "voor het opslaan".

Dan zou ik het in de Thisworkbook-module plaatsen.
Code: 
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If Application.CountA([u2:u3], [t9]) <> 3 Then
 Cancel = True
 MsgBox "verplichte cellen zijn niet ingevuld,... bestand niet opgeslagen"
End If
End Sub
Klik om te vergroten...

sorry sorry ik zie dit ik me vergist heb
het zit zo in mijn bestand zit een macro knop daar sla ik mijn gegevens op op de volgende pagina en zo zou ik graag zien nogmaals sorry
wat je hebt gemaakt werkt goed maar is dus niet wat ik bedoelden sorry nogmaals zou u er nog eens naar willen kijken
 
Je zat zelf aardig goed met de plek in jou code, het opslaan is niet echt opslaan maar overbrengen naar tabblad Jaar.

het moet in elk geval voordat je de cellen gaat kopieren.

Even een stukje uit de code met de nieuwe test ertussen.
Code: 
    If Fout > 0 Then
        Range("J5").Select
        MsgBox "Er ontbreekt een activiteit of een tijdstip.", _
            vbCritical, "Tijdstip en activiteit" 'is aantal tijden en activiteiten niet gelijk, dan melden
        End 'stoppen
    End If
    If Application.CountA([u2:u3], [t9]) <> 3 Then
        MsgBox "Productie uren of Aantal Elementen niet gevuld!", vbCritical
        End
    End If
    
    Range("A19:I19,M19:R19").Copy 'Kopieer de uren
 
Roeljongman mijn dank is groot ik kan nu van mijn avond gaan genieten
een fijne jaar wisseling en en gezond 2022 en wie weet tot dan
 
mooi dan was dit mijn laatste goede daad voor 2021 :p

Fijne jaarwisseling
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan