Afschrijving macro

Marky76 · 31 mei 2008

Beste,
Onderstaande die ik gekregen van Roccanio heb ik wat willen aanvullen met de code in het rood, maar ik krijg steeds een foutmelding.
Dus als er in K geen formule staat en M is verschillend van 0 dan mag de formule van de bovenste rij gekopieerd worden.
En als er in cel L een positief getal staat mag de hele rij gewist worden.

Code:

Sub Afschrijving()
Dim iSRij As Integer, iRij As Integer
    iRij = Range("A65536").End(xlUp).Row
    For iSRij = 4 To iRij
        If Cells(iSRij, "J").HasFormula = False And Cells(iSRij, "M") <> "" Then
        Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
        End If
              [COLOR="Red"] If Cells(iSRij, "K").HasFormula = False And Cells(iSRij, "M") <> "" Then
               Cells(iSRij, "K").Offset(-1, 0).Copy
               Cells(iSRij, "K").Paste
               Application.CutCopyMode = False
               End If
                        If Cells(iSRij, "L").Value > 1 Then
                           Row.Cells(iSRij, "L").Select
                           Selection.Delete
                        End If[/COLOR]                         
                            If Cells(iSRij, "L").Value < 1 Then
                               Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
                               Cells(iSRij, "L").Value = ""
                               Cells(iSRij, "H").Value = ""
                            End If
                            
        If Cells(iSRij, "F").HasFormula = False And Cells(iSRij, "G") <> "" Then
            Cells(iSRij, "F").Value = Cells(iSRij, "G").Value
            Cells(iSRij, "G").Value = ""
        End If
      
        
    Next
    Range("F2").Value = DateSerial(Year(Now()) - 1, 12, 31)
    Range("J2").Value = DateSerial(Year(Now()) - 1, 12, 31)
    Range("I2").Value = DateSerial(Year(Now()), 12, 31)
    Range("M2").Value = DateSerial(Year(Now()), 12, 31)

End Sub

Het lukt me niet om hem te doen werken.

Groeten,
Mark

Ginger · 31 mei 2008

Marky76, ff vlug zo uit de losse pols... (heb je bestand nog niet bekeken en de code verder niet getest). Je geeft namelijk in je tekst niet aan WAAR het werkelijk fout loopt. Het enige dat ik zie is het volgende...

en M is verschillend van 0

en

Code:

Cells(iSRij, "M") <> ""

De dubbele quote staat niet gelijk aan nul! Dus waar moet dat stukje code op testen? Op een lege cel (="") of op een cel die ongelijk is aan de getalwaarde nul?

Groet, Leo

Withaar · 31 mei 2008

De eerste nieuwe If lijkt me nergens voor nodig.
Waarom zou er in K geen formule staan?
N.b. hier staat ook een fout in..

De tweede kun je vervangen door;

Code:

    If Cells(iSRij, "L").Value > 1 Then
        Rows(iSRij).Select
        Selection.Delete Shift:=xlUp
    End If

Je probleem begind m.i. pas als je bij de (sub) totaal rijen aan komt.
Ook deze bevaten een waarde in kolom L, met een werkende code worden ook deze overscheven...

Code:

Sub Afschrijving()
Dim iSRij As Integer, iRij As Integer
    iRij = Range("A65536").End(xlUp).Row
    
For iSRij = 4 To iRij
    If Cells(iSRij, "J").HasFormula = False And Cells(iSRij, "M") <> "" Then
        Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
    End If
    
    ' Doel ?     
    'If Cells(iSRij, "K").HasFormula = False And Cells(iSRij, "M") <> "" Then
    '    Cells(iSRij, "K").Offset(-1, 0).Copy
    '    Cells(iSRij, "K").Paste
    '    Application.CutCopyMode = False
    'End If
                        
[COLOR="YellowGreen"]    If Cells(iSRij, "L").Value > 1 Then
        Rows(iSRij).Select
        Selection.Delete Shift:=xlUp
    End If[/COLOR]
                         
    If Cells(iSRij, "L").Value < 1 Then
        Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
        Cells(iSRij, "L").Value = ""
        Cells(iSRij, "H").Value = ""
    End If
                        
    If Cells(iSRij, "F").HasFormula = False And Cells(iSRij, "G") <> "" Then
        Cells(iSRij, "F").Value = Cells(iSRij, "G").Value
        Cells(iSRij, "G").Value = ""
    End If
Next
    
Range("F2").Value = DateSerial(Year(Now()) - 1, 12, 31)
Range("J2").Value = DateSerial(Year(Now()) - 1, 12, 31)
Range("I2").Value = DateSerial(Year(Now()), 12, 31)
Range("M2").Value = DateSerial(Year(Now()), 12, 31)

End Sub

Dit werkt overigens ook niet;

Code:

    If Cells(iSRij, "J").HasFormula = False And Cells(iSRij, "M") <> "" Then
        Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
    End If

D.w.z. formule of niet, de copy value wordt gewoon uitgevoerd...

Marky76 · 2 jun 2008

Beste,
Ik best uitleggen wat de macro juist moet doen. Het gaat hier om een afschrijvingstabel.
Bij de overgang van jaar x naar jaar x + 1 moeten de bedragen in de kolom G naar kolom F gaan. De marco mag niets doen aan de subtotalen. De bedragen in kolom M moeten gaan naar kolom J.
Soms gebeuren er transferts van investeringen in de tabel van de ene rekening naar de andere en dit gebeurd manueel. En dan heb je zo'n rode lijn zoals in het tabblad "Afschrijvingstabel". De investering is getransfereerd naar rekening 2350070.

Bij de overdracht moet de macro de lijn bij rekening 2350060 wissen, wat de macro zoals hij nu is ook doet, maar de lijn die in het tabbald "Overdracht" in het groen staat heeft de macro niet bewerkt, daar werd het bedrag in kolom M staat niet overgebracht naar kolom J.

In cel K 28 in tabblad "Overdracht" zie je dat er geen formule in de cel staat. Dit komt omdat dit bedrag omwille van boekhoudkundige redenen zo manueel ingevuld is geweest.
De macro zou indien de cel K geen formule bevat de formule zoals in de cel er net boven moeten plaatsen, anders klopt de afschrijvingstabel niet.

Als de macro uitgevoerd is moet het Subtotaal van 376379,78 in Kolom I dus voorkomen in het subtotaal kolom F en het bedrag van 331149,34 in kolom M moet voorkomen in het subtotaal kolom J. Als dit klopt heeft de macro zijn werk gedaan.

Withaar · 2 jun 2008

Zal best wel met een macro kunnen, maar ik ga me vingers hier niet aan branden.., is me net iets te ingewikkeld.

Marky76 · 2 jun 2008

Is er iemand die me kan helpen, de maco is zo goed als af. Enkel de groene lijn in het tabblad "overdracht" moet nog inorde komen in cel K28 moet nog enkel de formule op een of andere manier terecht komen, dezelfde formule als de cel er net boven.
Dan is de macro kompleet.

Marky76 · 2 jun 2008

Code:

 If Cells(iSRij, "K").HasFormula = False And Cells(iSRij, "M") <> "" Then
               Cells(iSRij, "K").Formula = Cells(iSRij, "K").Offset(-1).Formula
               End If
               
                       If Cells(iSRij, "L").Value > 1 Then
                           Rows(iSRij).Select
                           Selection.Delete Shift:=xlUp
                        End If

Met deze twee stukjes code zit ik eigenlijk nog vast.
De eerste if daar kopieert hij goed de formule maar behoud de waarden van de bovenste lijn de formule zou moeten opschuiven zoals je een formule gewoon manueel in het excel blad naar beneden zou kopiëren.

En door de tweede if constructie word de lijn wel degelijk gewist, maar dan word de eerste voldende lijn niet door de macro bewerkt, hij slaagt die over waardoor de waarde in cel M niet naar Cel J word gezet.

Groeten,
Mark

Wigi · 2 jun 2008

1ste IF:

als je nu eens met relatieve verwijzingen werkt in de formules, niet met absolute verwijzingen.

2de IF:

bij het verwijderen van rijen moet je van onder naar boven werken, aangezien je sommige rijen overslaat als je gaat deleten, tijdens de lus.

Wigi

Marky76 · 3 jun 2008

Heb er tot 23:42 uur nog aan bezig geweest, maar geraak er niet uit. Ben nog belange gene goeie in vba en vergeet dat waarschijnlijk een haakje of een punt. Ik heb gisteren nog veel zitten opzoeken en lezen, maar geraak er nog niet uit. Heb veel snippets, maar kan er niet uithalen wat ik nodig heb.

Marky76 · 19 jun 2008

Help, ik graag niet verder.
In de rode cellen heb ik nog een probleempje heb de uitleg er naast gezet.
In het tabblad Afschrijvingstabel staat de tabel alvorens de macro er werd op losgelaten en in het tabblad Overdracht heb je de tabel na de bewerkingen van de macro. Maar in de cellen in het rood heb ik nog een probleempje. De uitleg staat er naast.
Kan iemand mij uit de penarie helpen?

Groeten,
Mark

Wigi · 19 jun 2008

Als je rijen delete moet je sowieso van onder naar boven werken.

Anders krijg je de problemen zoals bij jou: de lus komt bij rij 2, die wordt gedeletet. Dan rij 3, maar door de delete is de oorspronkelijke rij 3 rij 2 geworden. Dus die wordt overgeslagen.

Wigi

Marky76 · 20 jun 2008

Dan moet ik heel de macro herschijven of niet?
Ik heb hem met snippets van verschillende mensen die me geholpen hebben in elkaar gekregen, maar hem herbeginnen, dat kan ik niet zomaar alleen uit mezelf.

Wigi · 20 jun 2008

Inderdaad, het zal toch voor een deel herschreven moeten worden. Maar het is nu weekend dus dan heb je tijd

Marky76 · 23 jun 2008

Hallo Wigi,

Het probleem dat ik had op regel 28 heb ik kunnen oplossen. Zie blauwe kleur in de code.
Maar om van onder naar boven te vertrekken daar geraak ik nog niet uit.

Code:

Sub Afschrijving()
Dim iSRij As Integer, iRij As Integer
    iRij = Range("A65536").End(xlUp).Row
    For iSRij = 4 To iRij
        
        If Cells(iSRij, "J").HasFormula = False And Cells(iSRij, "M") <> "" Then
        Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
        End If
         
              [COLOR="Blue"] If Cells(iSRij, "K").HasFormula = False And Cells(iSRij, "M") <> "" Then
               Cells(iSRij, "K").Offset(-1).Copy Destination:=Cells(iSRij, "K")
               End If[/COLOR]               
                       If Cells(iSRij, "L").Value > 1 Then
                           Rows(iSRij).Select
                           Selection.Delete Shift:=xlUp
                        End If
                          
    'na dit word de volgende lijn niet aangepast, de waarde van in M word niet naar
    'cel J overgebracht na het deleten van de rij.
                                   
                           If Cells(iSRij, "L").Value < 1 Then
                             '  Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
                              Cells(iSRij, "L").Value = ""
                             ' Cells(iSRij, "H").Value = ""
                            End If
                            
        If Cells(iSRij, "F").HasFormula = False And Cells(iSRij, "G") <> "" Then
            Cells(iSRij, "F").Value = Cells(iSRij, "G").Value
            Cells(iSRij, "G").Value = ""
        End If
      
        If Cells(iSRij, "F").HasFormula = False And Cells(iSRij, "H") < 0 Then
            Cells(iSRij, "F").Value = Cells(iSRij, "I").Value
            Cells(iSRij, "H").Value = ""
        End If
                
        
    Next
    
    
    Range("F2").Value = DateSerial(Year(Now()) - 1, 12, 31)
    Range("J2").Value = DateSerial(Year(Now()) - 1, 12, 31)
    Range("I2").Value = DateSerial(Year(Now()), 12, 31)
    Range("M2").Value = DateSerial(Year(Now()), 12, 31)

End Sub

Groeten,
Mark

Marky76 · 24 jun 2008

Iemand enig idee?

Groeten,
Mark

Wigi · 24 jun 2008

Met de lus omdraaien, bedoel ik:

Code:

For iSRij = iRij To 4 Step -1

Hoogstwaarschijnlijk zal je nog dingen moeten aanpassen, maar dit is het eerste dat je moet doen.

Marky76 · 24 jun 2008

Dan was ik er niet zo ver van ik had het volgende geprobeerd, maar dit gaf geen goed resultaat.

Code:

For iSRij = iRij To 4

Marky76 · 24 jun 2008

Over het woordje Step dat je gebruikt vind ik geen info in de bibliotheek als ik F2 doe.

Het is wel aardig opgeschoten nu, maar hij heeft de totalen weggedaan bij mijn eerste investeringsgroep is dan precies niet verder gegaan met het uitvoeren van de code.
We zijn al verder geraakt, dat is al goed. :thumb:

Marky76 · 24 jun 2008

Wigi,
Dit is de code op dit moment:

Code:

Sub Afschrijving()
Dim iSRij As Integer, iRij As Integer
    iRij = Range("A65536").End(xlUp).Row
    [COLOR="Green"]For iSRij = iRij To 4 Step -1[/COLOR]
        
        If Cells(iSRij, "J").HasFormula = False And Cells(iSRij, "M") <> "" Then
        Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
        End If
         
               If Cells(iSRij, "K").HasFormula = False And Cells(iSRij, "M") <> "" Then
               Cells(iSRij, "K").Offset(-1).Copy Destination:=Cells(iSRij, "K")
               End If
               
                      [COLOR="Blue"] If Cells(iSRij, "L").HasFormula = False And Cells(iSRij, "L").Value > 1 Then[/COLOR]                           Rows(iSRij).Select
                           Selection.Delete Shift:=xlUp
                       End If
                    
                        
    'na dit word de volgende lijn niet aangepast, de waarde van in M word niet naar
    'cel J overgebracht na het deleten van de rij.
                                   
                           If Cells(iSRij, "L").Value < 1 Then
                             '  Cells(iSRij, "J").Value = Cells(iSRij, "M").Value
                              Cells(iSRij, "L").Value = ""
                             ' Cells(iSRij, "H").Value = ""
                            End If
                            
        If Cells(iSRij, "F").HasFormula = False And Cells(iSRij, "G") <> "" Then
            Cells(iSRij, "F").Value = Cells(iSRij, "G").Value
            Cells(iSRij, "G").Value = ""
        End If
      
        If Cells(iSRij, "F").HasFormula = False And Cells(iSRij, "H") < 0 Then
            Cells(iSRij, "F").Value = Cells(iSRij, "I").Value
            Cells(iSRij, "H").Value = ""
        End If
        
        
             
        
    Next
    
    
    Range("F2").Value = DateSerial(Year(Now()) - 1, 12, 31)
    Range("J2").Value = DateSerial(Year(Now()) - 1, 12, 31)
    Range("I2").Value = DateSerial(Year(Now()), 12, 31)
    Range("M2").Value = DateSerial(Year(Now()), 12, 31)

End Sub

Ik heb de blauwe code erbij gedaan, want hij wiste de totalen van mijn eerste investeringrekening.

Nu werkt die helemaal! Yohaaa!
Graag had ik de functie geweten van het stukje code Step -1, want vind hierover niets in de bibliotheek of in de help.

Bedankt Wigi,

Ga nu slapen, zit met zware bronchitis, maar de curiositeit heeft me aan de pc gehouden.

Groeten,
Mark

Wigi · 24 jun 2008

Jij ging in de eerste lus bv. van rij 4 tot 10.

Dan draaide je om en ging je dus van rij 10 tot 4. Resultaat: je komt helemaal NIET in de lus terecht.

Zoiets ga je na door met F8 stap voor stap door de code te gaan en te kijken welke waarde elke variabele heeft op dat moment.

Met de Step -1 doe je rij 10, dan rij 9, dan rij 8, tot rij 4.

Snel beterschap gewenst.

Wigi

Afschrijving macro

Gebruiker

Bijlagen

Terugkerende gebruiker

Verenigingslid

Gebruiker

Bijlagen

Verenigingslid

Gebruiker

Gebruiker

Inventaris

Gebruiker

Gebruiker

Bijlagen

Inventaris

Gebruiker

Inventaris

Gebruiker

Gebruiker

Inventaris

Gebruiker

Gebruiker

Gebruiker

Inventaris

Wij waarderen jouw privacy