Eerst volgende lege regel zoeken ander sheet

Status
Niet open voor verdere reacties.
R

Robert Smidt

Gebruiker
Lid geworden
26 mei 2009
Berichten
947
Beste Helpmij'ers,

Onderstaande code gaat de cursor naar de juiste sheet en naar de laatste (gevulde) regel, echter ik wil dat deze naar de eerstvolgende lege regel gaat.

'Op duurzaam bedrijfsmiddel afschrijven
If Not IsError(Application.Match(Cells(Target.Row, 6), Sheets("Data").[b168:b175], 0)) And Range("I" & Target.Row) <> "" Then
MsgBox "Het betreft hier een duurzaam bedrijfsmiddel waarop afgeschreven moet worden!"
Application.Goto Sheets("Afschrijving").[A1]
Selection.End(xlDown).Select
rij = ActiveCell.Row + 1
End If

Het probleem zit in regel: "rij = ActiveCell.Row + 1".

Wat heb ik fout in deze regel.

Alvast bedankt.

M.vr.gr.
Robert
 
De simpele manier in je situatie.
Wijzig:
rij = ActiveCell.Row + 1

In:
Application.Goto Cells(ActiveCell.Row + 1, 1)
 
Sorry, dit werkt niet. Hij blijft zelfs in de sheet staan van waaruit ik werk. Als ik jouw code niet gebruik, gaat deze wel naar de juist sheet. Wanneer ik jouw code gebruik en ik handmatig naar de doelsheet ga, dan, staat de cursor nog steeds in de laatste gevulde regel.
 
Dan ben ik benieuwd of je de aanwijzing goed hebt opgevolgd want hier werkt het prima.
 
Ik vind het ook vreemd omdat bij andere programma's het bij mij ook werkt. Wellicht dat een voorgaande code deze code frustreert. Ik stuur jou de volledige vba, zie helemaal onderaan:

Code: 
'Versie 1.3
'Uitgaven
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False

If Not Intersect(Target, Range("a13:y500")) Is Nothing Then
    If Selection.Count = 1 Then
    If Not Intersect(Target, Union(Columns(1), Columns(2), Columns(3), Columns(4), Columns(5), Columns(6), Columns(7), Columns(8), Columns(9), Columns(10), Columns(11), Columns(12), Columns(13), Columns(14), Columns(15), Columns(18), Columns(23), Columns(32))) Is Nothing Then
        With Target

        If .Column = 1 And Not IsEmpty(Target) Then Application.Goto .Offset(, 2) 'kolom a
       ' If .Column = 2 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom b
        If .Column = 3 And Not IsEmpty(Target) Then Application.Goto .Offset(, 3) 'kolom c
        
        If .Column = 5 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom e
        
        If .Column = 6 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom f
        If .Column = 7 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom g
        If .Column = 8 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom h
        If .Column = 9 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom I
        If .Column = 10 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom J
        If .Column = 11 And Not IsEmpty(Target) Then Application.Goto .Offset(, 1) 'kolom K


        'Boeknummer ophogen uitgaven
        If Range("a" & Target.Row) <> "" And Range("b" & Target.Row) = "" And Range("i" & Target.Row) > 0 Then '
            Range("b" & Target.Row) = Sheets("Data").Range("C49") 'U
        End If
        
        If Range("a" & Target.Row) <> "" And Range("b" & Target.Row) = "" And Range("i" & Target.Row) < 0 Then
            Range("b" & Target.Row) = Sheets("Data").Range("C51") 'CRU
        End If
                
       'Kopieren van de formules t.b.v. de openstaande crediteuren!
        If Range("g" & Target.Row) <> "" And Range("q" & Target.Row) = "" Then 'Range("Q" & Target.Row) = Range("Q5").Value
            rij = 0 + ActiveCell.Row
           Range("q5:t5").Select
           Selection.Copy
           Cells(rij, 17).Select
           ActiveSheet.Paste
          ' Cells(rij, 2).Select
        
           rij = 0 + ActiveCell.Row
           Range("v5:ab5").Select
           Selection.Copy
           Cells(rij, 22).Select
           ActiveSheet.Paste
           
           rij = 0 + ActiveCell.Row
           Range("h5").Select
           Selection.Copy
           Cells(rij, 8).Select
           ActiveSheet.Paste
        
        Application.Goto .Offset(, 2) 'ga naar kolom i
        End If
        
  
'B T W  H O O G  B E R E K E N E N
        If Range("h" & Target.Row) = Sheets("Persoonlijke instelling").[Btwhoogtarief].Value Or Range("h" & Target.Row) = "Buiten EU" Then  '
              ' If Range("l" & Target.Row) <> "" Then Range("l" & Target.Row) = ""
              ' If Range("j" & Target.Row) <> "" Then Range("j" & Target.Row) = ""
            
            'Btw-bedrag berekenen incl. btw-prijs
            If Range("I" & Target.Row) <> "" And Range("J" & Target.Row) = "" Then
                Range("k" & Target.Row) = ((Range("I" & Target.Row) / [Btwhoogformule].Value) * (100 * [Btwhoogtarief].Value))
                Range("j" & Target.Row) = (Range("I" & Target.Row) - (Range("k" & Target.Row)))
            End If
                        
           'Btw-bedrag berekenen excl btw-prijs
            If Range("J" & Target.Row) <> "" And Range("I" & Target.Row) = "" Then
                'Range("K" & Target.Row) = (Range("J" & Target.Row) * (Range("H" & Target.Row)))
                Range("K" & Target.Row) = (Range("J" & Target.Row) * [Btwhoogtarief].Value)
                Range("I" & Target.Row) = (Range("J" & Target.Row) + (Range("K" & Target.Row) + (Range("L" & Target.Row))))
            End If
          End If
        
'B T W  L A A G  B E R E K E N E N
         If Range("h" & Target.Row) = Sheets("Persoonlijke instelling").[Btwlaagtarief].Value Then
              '  If Range("K" & Target.Row) <> "" Then Range("K" & Target.Row) = ""
              '  If Range("j" & Target.Row) <> "" Then Range("j" & Target.Row) = ""

            'Btw-bedrag berekenen incl. btw-prijs
            If Range("I" & Target.Row) <> "" And Range("J" & Target.Row) = "" Then
                Range("L" & Target.Row) = ((Range("I" & Target.Row) / Sheets("Persoonlijke instelling").[Btwlaagformule].Value) * (100 * (Range("H" & Target.Row))))
                Range("j" & Target.Row) = (Range("I" & Target.Row) - (Range("L" & Target.Row)))
            End If
                        
             'Btw-bedrag berekenen excl btw-prijs
            If Range("J" & Target.Row) <> "" And Range("I" & Target.Row) = "" Then
                Range("L" & Target.Row) = (Range("J" & Target.Row) * (Range("H" & Target.Row)))
                Range("I" & Target.Row) = (Range("J" & Target.Row) + (Range("L" & Target.Row)))
            End If
         End If
    
'B T W  O V E R I G  B E R E K E N E N
        If Range("h" & Target.Row) = "Geen" Or Range("h" & Target.Row) = "n.v.t." Or Range("h" & Target.Row) = "Marge" Or Range("h" & Target.Row) = "Vrijgesteld" Or Range("h" & Target.Row) = "Verlegd" Or Range("h" & Target.Row) = "Binnen EU" Then
            If Range("I" & Target.Row) <> "" And Range("J" & Target.Row) = "" Then
                Range("J" & Target.Row) = Range("I" & Target.Row)
            End If
        End If
    
        If Range("h" & Target.Row) = "Geen" Or Range("h" & Target.Row) = "n.v.t." Or Range("h" & Target.Row) = "Marge" Or Range("h" & Target.Row) = "Vrijgesteld" Or Range("h" & Target.Row) = "Verlegd" Or Range("h" & Target.Row) = "Binnen EU" Then
            If Range("J" & Target.Row) <> "" And Range("I" & Target.Row) = "" Then
                Range("I" & Target.Row) = Range("J" & Target.Row)
            End If
        End If

        'Foutieve keuze voldaan per:
        If Range("G" & Target.Row) = "Op rekening" Then Cells(Target.Row, 13).Resize(, 4).ClearContents

'CREDITEUREN (de betaling is verricht)
   'If Range("G" & Target.Row) <> "Op rekening" And Range("i" & Target.Row) <> "" And Range("J" & Target.Row) <> "" And Range("N" & Target.Row) = "" Then
    If Range("G" & Target.Row) <> "Op rekening" And Range("i" & Target.Row) <> "" And Range("N" & Target.Row) = "" Then
        Select Case MsgBox("Het betaalde bedrag is " & "€ " & Range("i" & Target.Row) & ".  Is dit bedrag correct?", vbYesNo, "BETALINGSMUTATIE")
        Case vbYes
            Range("m" & Target.Row) = Range("I" & Target.Row).Value
        Case vbNo
            Range("m" & Target.Row).Value = InputBox("Hoeveel heeft u betaald?", "BETALINGSMUTATIE  (Let op! zet een punt i.p.v. een komma)")
        End Select
        
        datum = InputBox("Betaaldatum dd-mm-jjjj", , Format(Range("a" & Target.Row), "dd-mm-yyyy"))
        If Trim(datum) <> "" Then
            If IsDate(datum) Then Range("N" & Target.Row) = CDate(datum)
        End If
        Application.Goto .Offset(, 5) 'kolom c
    End If
    
    If Range("O" & Target.Row) <> "" And Range("P" & Target.Row) = "" Then
        correctie = MsgBox("Het betaalde bedrag is " & "€ " & Range("i" & Target.Row) - Range("m" & Target.Row) & ".  Is dit bedrag correct?", vbYesNo, "BETALINGSMUTATIE")
        If correctie = vbYes Then
           Range("O" & Target.Row) = Range("I" & Target.Row).Value - Range("M" & Target.Row).Value
        Else: Range("O" & Target.Row).Value = InputBox("Hoeveel heeft u betaald?", "BETALINGSMUTATIE  (Let op! zet een punt i.p.v. een komma)")
        End If
        
        datum = InputBox("Betaaldatum dd-mm-jjjj", , Format(Range("a" & Target.Row), "dd-mm-yyyy"))
        If Trim(datum) <> "" Then
            If IsDate(datum) Then Range("P" & Target.Row) = CDate(datum)
        End If
        Application.Goto .Offset(, -14) 'kolom a
    End If
    
'Kassaldo is negatief
    If Range("A" & Target.Row) <> "" And Range("C" & Target.Row) = "" Then
        If Sheets("Kolommenbalans").Range("E29") - Sheets("Kolommenbalans").Range("F29") < 0 Then CreateObject("WScript.Shell").Popup "Het kassaldo is negatief hetgeen op een fout berust, herstel eerst deze fout of ga naar INTERNE OVERBOEKING en boek dit als KASVERSCHIL!", 20, "Waarschuwing: Je hoeft niet op OK te klikken", vbCritical
    End If
    
'Wanneer het ex-btw-bedrag en het btw-bedrag niet gelijk is aan het incl. btw-bedrag
    If Range("l" & Target.Row) = "" And Range("k" & Target.Row) + Range("j" & Target.Row) <> Range("I" & Target.Row) Then Range("k" & Target.Row) = (Range("I" & Target.Row) - (Range("j" & Target.Row)))
    If Range("k" & Target.Row) = "" And Range("l" & Target.Row) + Range("j" & Target.Row) <> Range("I" & Target.Row) Then Range("l" & Target.Row) = (Range("I" & Target.Row) - (Range("j" & Target.Row)))
    
'Bedrijfsmiddel onterrecht als kosten geboekt
    If Not Intersect(Target, Range("j2:j500")) Is Nothing Then
        Application.EnableEvents = False
        If Not IsError(Application.Match(Cells(Target.Row, 6), Sheets("Data").[b56:b152], 0)) And Range("j" & Target.Row) > 450 Then CreateObject("WScript.Shell").Popup "Je hebt een bedrijfsmiddel (> €450) als kosten geboekt, dat is niet juist. Ga naar de kolom Catagorie en wijzig deze in een (duurzaam) bedrijfsmiddel", 60, "Waarschuwing: Fout herstellen", vbCritical
        Application.EnableEvents = True
    End If
    
    
    If Not Intersect(Target, Range("i2:i500")) Is Nothing Then
        Application.EnableEvents = False
        If Not IsError(Application.Match(Cells(Target.Row, 6), Sheets("Data").[b56:b152], 0)) And Range("i" & Target.Row) > 545 Then CreateObject("WScript.Shell").Popup "Je hebt een bedrijfsmiddel (> €450) als kosten geboekt, dat is niet juist. Ga naar de kolom Catagorie en wijzig deze in een (duurzaam) bedrijfsmiddel", 60, "Waarschuwing: Fout herstellen", vbCritical
        Application.EnableEvents = True
    End If
    
 'Wanneer er een fout zit in de kolommenbalans
If Range("i" & Target.Row) <> "" And Range("j" & Target.Row) <> "" Then 'Or Range("k" & Target.Row) <> "" Or Range("l" & Target.Row) <> "" Then
    Sheets("Kolommenbalans").Select
    ActiveSheet.Range("$M$2:$M$175").AutoFilter Field:=1
    ActiveSheet.Range("$M$2:$M$175").AutoFilter Field:=1, Criteria1:="show"
    Sheets("Uitgaven").Select
    If Sheets("Kolommenbalans").Range("e104") <> Sheets("Kolommenbalans").Range("f104") Then CreateObject("WScript.Shell").Popup "Er zit een fout in de balansberekening, ga niet verder en meld de fout aan Cashflow-Control!", 10, "Waarschuwing: ", vbCritical
End If

'Op duurzaam bedrijfsmiddel afschrijven
    If Not IsError(Application.Match(Cells(Target.Row, 6), Sheets("Data").[b168:b175], 0)) And Range("I" & Target.Row) <> "" Then
        MsgBox "Het betreft hier een duurzaam bedrijfsmiddel waarop afgeschreven moet worden!"
        Application.Goto Sheets("Afschrijving").[A1]
        Selection.End(xlDown).Select
       rij = ActiveCell.Row + 1
        ' Application.Goto Cells(ActiveCell.Row + 1, 1)
    End If

    End With
  End If
End If
End If

Application.EnableEvents = True
  




End Sub
 
Die code kan ik uiteraard niet testen maar die wijziging ziet er in ieder geval goed uit. Heb je ook met F8 gevolgd of hij wel dat stukje code doorloopt?
 
Nee, ik weet helaas niet hoe ik dat moet gebruiken omdat de code geactiveerd wordt bij een bepaalde situatie.
 
Als je de daar genoemde Msgbox te zien krijgt betekent het dat hij die code wel doorloopt en anders niet.
 
Die krijg ik wel in beeld en ga ervan uit dat hij de code doorloopt. Ik heb inmiddels een nieuwe sheet aangemaakt en gekeken of de code daarop werkt, de uitwerking is precies hetzelfde.
 
In de code die je plaatste staat de wijziging met een commentaarteken ervoor en de oude regel nog actief. Dat heb je toch wel aangepast neem ik aan?
 
Ik probeer een bestand te uploaden, maar deze blijft te groot. Ik probeer het later weer. Alvast heel erg bedankt.
 
Sla het bestand op als .xlsb en plaats die dan.
 
Probeer van de code iets leesbaars te maken. Vermijd het gebruik van select.

Als antwoord op de vraag
Code: 
Application.Goto Sheets("Afschrijving").[A1].End(xlDown).Offset(1)

Als voorbeeldje van leesbaar maken (Ik weet natuurlijk niet of het geheel past binnen jouw bestand en is maar een stukje van het geheel);)

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("a13:y500")) Is Nothing And Target.Count = 1 Then
    Application.EnableEvents = False
    With Target
        If .Value <> "" Then
            Select Case .Column
                Case 1: Application.Goto .Offset(, 2)
                Case 3: Application.Goto .Offset(, 3)
                Case 5 To 11: Application.Goto .Offset(, 1)
            End Select
        End If
        'Boeknummer ophogen uitgaven
        If Range("a" & .Row) <> "" And Range("b" & .Row) = "" Then
            If Range("i" & .Row) > 0 Then Range("b" & .Row) = Sheets("Data").Range("C49") Else Range("b" & .Row) = Sheets("Data").Range("C51")
        End If
        'Kopieren van de formules t.b.v. de openstaande crediteuren!
        If Range("g" & .Row) <> "" And Range("q" & .Row) = "" Then
            Range("q5:t5").Copy Cells(.Row, 17)
            Range("v5:ab5").Copy Cells(.Row, 22)
            Range("h5").Copy Cells(.Row, 8)
            Application.Goto Cells(.Row, 9) 'ga naar kolom i
        End If
    End With
End If
Application.EnableEvents = True
End Sub
 
Laatst bewerkt:
Opgelost

Beste mensen,

Het probleem is opgelost met de code: Application.Goto Sheets("Afschrijving").[A1].End(xlDown).Offset(1)

Heel hartelijk bedankt voor het meedenken en oplossen van het probleem.

Groeten, Robert
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan