Probleem met if, else end if

Status
Niet open voor verdere reacties.
J

Jamara

Gebruiker
Lid geworden
15 aug 2008
Berichten
21
Marco Sub LegeRegel()
Macro gemaakt om tussentelling te maken op regel 50,98,146 etc etc
Elke stukje van de macro begint met if, daarna else en end if
Als regel leeg is lege regels in bestand verwijderen; laatste regel is dan regel met totaaltelling
Als regel totaaltelling bevat map opslaan en applicatie afsluiten.
In de VBA Mode met "foutopsporing stap voor stap" werkt de macro zoals deze uitgevoerd zou moeten worden
In de VBA Module met "uitvoering/ sub/userform uitvoeren" loopt de macro het restant van de macro nog af
en dat is niet de bedoeling.
Foutmelding;"Fout 13 tijdens uitvoering typen komen niet met elkaar overeen"
Daarna kun je de macro beëindigen of de foutopsporing starten.
Wie kan mij helpen om dit problemop te lossen.
Het xls bestand is bijgevoegd
 
Laatst bewerkt:
1. ontdoe je code van 'opneem-VBA'

Bijv.
Code: 
ChDir "O:\Oosterhout\Financieel\Declaratieoverzichten\07 juli"
   ActiveWorkbook.SaveAs Filename:= _
       "O:\Oosterhout\Financieel\Declaratieoverzichten\07 juli\Decloverz31072008 test1.xls", FileFormat:=xlNormal _
       , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
       CreateBackup:=False
kan vervangen worden door
Code: 
ActiveWorkbook.SaveAs "O:\Oosterhout\Financieel\Declaratieoverzichten\07 juli\Decloverz31072008 test1.xls"
Dat is voldoende.

2. vermijd de methodes select en Activate; die zijn in meer dan 99% overbodig.

jouw hele macro kan waarschijnlijk in ca. 10 regels uitgevoerd worden.
 
Ik heb module 3 uit het bestandje voor je vereenvoudigd. Weet niet wat module 2 voor inhoud heeft maar leek mij hetzelfde.


Code: 
Sub LegeRegel()
Sheets("Blad1").Select
'Het invoegen van een totaal of tussentellingsregel op rij 50
' a het invoegen van een transportregel; er volgen nog 1 of meerdere bladen (Versie 2.4)
    
For blad = 50 To 146 Step 48 ' voor de 146 kun je elk getal  nemen met achtneming van elke keer een stap van 48
    If Cells(blad, 1).Value > 0 Then
        Range(Cells(blad, 1), Cells(blad + 1, 1)).EntireRow.Insert Shift:=xlDown
        Cells(blad, 2).Value = "transporteren"
        Cells(blad + 1, 2).Value = "transport"
        Cells(blad, 6).FormulaR1C1 = "=SUBTOTAL(9,R[-47]C:R[-1]C)"
        Cells(blad, 6).AutoFill Destination:=Range(Cells(blad, 6), Cells(blad, 13)), Type:=xlFillDefault
        Cells(blad, 13).Copy Cells(blad, 15)
        Cells(blad + 1, 6).FormulaR1C1 = "=R[-1]C"
        Cells(blad + 1, 6).AutoFill Destination:=Range(Cells(blad + 1, 6), Cells(blad + 1, 15)), Type:=xlFillDefault
        Cells(blad + 1, 14).ClearContents
    
'b  het invoegen van een totaalregel; er volgen geen bladen meer
    Else: Cells(blad, 2).Value = "totaal"
        Cells(blad, 6).FormulaR1C1 = "=SUBTOTAL(9,R[-47]C:R[-1]C)"
        Cells(blad, 6).AutoFill Destination:=Range(Cells(blad, 6), Cells(blad, 13)), Type:=xlFillDefault
        Cells(blad, 13).Copy Cells(blad, 15)
    
' Dubbelstreep onder eindtelling maken
        Range(Cells(blad, 6), Cells(blad, 15)).Select
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .Weight = xlThick
            End With
 
'Verwijderen van lege regels
    Range(Cells(blad - 48, 1), Cells(blad - 1, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    Next blad

'bestand opslaan als Excel bestand
   ActiveWorkbook.SaveAs "O:\Oosterhout\Financieel\Declaratieoverzichten\07 juli\Decloverz31072008 test1.xls"
'   Application.ScreenUpdating = True (is onderdeel ivm andere macro)
    Application.Quit
 

 End Sub
 
Laatst bewerkt:
Relleboer zei:
Ik heb module 3 uit het bestandje voor je vereenvoudigd. Weet niet wat module 2 voor inhoud heeft maar leek mij hetzelfde.


Code: 
Sub LegeRegel()
Sheets("Blad1").Select
'Het invoegen van een totaal of tussentellingsregel op rij 50
' a het invoegen van een transportregel; er volgen nog 1 of meerdere bladen (Versie 2.4)
    
For blad = 50 To 146 Step 48 ' voor de 146 kun je elk getal  nemen met achtneming van elke keer een stap van 48
    If Cells(blad, 1).Value > 0 Then
        Range(Cells(blad, 1), Cells(blad + 1, 1)).EntireRow.Insert Shift:=xlDown
        Cells(blad, 2).Value = "transporteren"
        Cells(blad + 1, 2).Value = "transport"
        Cells(blad, 6).FormulaR1C1 = "=SUBTOTAL(9,R[-47]C:R[-1]C)"
        Cells(blad, 6).AutoFill Destination:=Range(Cells(blad, 6), Cells(blad, 13)), Type:=xlFillDefault
        Cells(blad, 13).Copy Cells(blad, 15)
        Cells(blad + 1, 6).FormulaR1C1 = "=R[-1]C"
        Cells(blad + 1, 6).AutoFill Destination:=Range(Cells(blad + 1, 6), Cells(blad + 1, 15)), Type:=xlFillDefault
        Cells(blad + 1, 14).ClearContents
    
'b  het invoegen van een totaalregel; er volgen geen bladen meer
    Else: Cells(blad, 2).Value = "totaal"
        Cells(blad, 6).FormulaR1C1 = "=SUBTOTAL(9,R[-47]C:R[-1]C)"
        Cells(blad, 6).AutoFill Destination:=Range(Cells(blad, 6), Cells(blad, 13)), Type:=xlFillDefault
        Cells(blad, 13).Copy Cells(blad, 15)
    
' Dubbelstreep onder eindtelling maken
        Range(Cells(blad, 6), Cells(blad, 15)).Select
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .Weight = xlThick
            End With
 
'Verwijderen van lege regels
    Range(Cells(blad - 48, 1), Cells(blad - 1, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    Next blad

'bestand opslaan als Excel bestand
   ActiveWorkbook.SaveAs "O:\Oosterhout\Financieel\Declaratieoverzichten\07 juli\Decloverz31072008 test1.xls"
'   Application.ScreenUpdating = True (is onderdeel ivm andere macro)
    Application.Quit
 

 End Sub
Klik om te vergroten...
 
Relleboer zei:
Ik heb module 3 uit het bestandje voor je vereenvoudigd. Weet niet wat module 2 voor inhoud heeft maar leek mij hetzelfde.


Code: 
Sub LegeRegel()
Sheets("Blad1").Select
'Het invoegen van een totaal of tussentellingsregel op rij 50
' a het invoegen van een transportregel; er volgen nog 1 of meerdere bladen (Versie 2.4)
    
For blad = 50 To 146 Step 48 ' voor de 146 kun je elk getal  nemen met achtneming van elke keer een stap van 48
    If Cells(blad, 1).Value > 0 Then
        Range(Cells(blad, 1), Cells(blad + 1, 1)).EntireRow.Insert Shift:=xlDown
        Cells(blad, 2).Value = "transporteren"
        Cells(blad + 1, 2).Value = "transport"
        Cells(blad, 6).FormulaR1C1 = "=SUBTOTAL(9,R[-47]C:R[-1]C)"
        Cells(blad, 6).AutoFill Destination:=Range(Cells(blad, 6), Cells(blad, 13)), Type:=xlFillDefault
        Cells(blad, 13).Copy Cells(blad, 15)
        Cells(blad + 1, 6).FormulaR1C1 = "=R[-1]C"
        Cells(blad + 1, 6).AutoFill Destination:=Range(Cells(blad + 1, 6), Cells(blad + 1, 15)), Type:=xlFillDefault
        Cells(blad + 1, 14).ClearContents
    
'b  het invoegen van een totaalregel; er volgen geen bladen meer
    Else: Cells(blad, 2).Value = "totaal"
        Cells(blad, 6).FormulaR1C1 = "=SUBTOTAL(9,R[-47]C:R[-1]C)"
        Cells(blad, 6).AutoFill Destination:=Range(Cells(blad, 6), Cells(blad, 13)), Type:=xlFillDefault
        Cells(blad, 13).Copy Cells(blad, 15)
    
' Dubbelstreep onder eindtelling maken
        Range(Cells(blad, 6), Cells(blad, 15)).Select
            With Selection.Borders(xlEdgeBottom)
                .LineStyle = xlDouble
                .Weight = xlThick
            End With
 
'Verwijderen van lege regels
    Range(Cells(blad - 48, 1), Cells(blad - 1, 1)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End If
    Next blad

'bestand opslaan als Excel bestand
   ActiveWorkbook.SaveAs "O:\Oosterhout\Financieel\Declaratieoverzichten\07 juli\Decloverz31072008 test1.xls"
'   Application.ScreenUpdating = True (is onderdeel ivm andere macro)
    Application.Quit
 

 End Sub
Klik om te vergroten...

Hallo Relleboer,
Ik heb de code in het werkblad geplaatst.
De code werkt maar gedeeltelijk.
Na uitvoering blijkt dat de tussentellingen op regel 50/51 verdwenen zijn,
volgens mij als gevolg van het onderdeel "Verwijder lege regel".
Tevens staan er op regel 98 nog gegevens, hetgeen niet zou moeten
omdat na de laatste totaalregel de rest van het werkblad leeg zou moeten zijn.
Kun je me nog verder helpen???
Alvast bedankt voor de genomen en nog te nemen moeite,
Jamara
 
Reactie op bericht Relleboer

Goede avond Relleboer,
Sorry maar hier ben ik weer.
Heb macro getest.
Geeft nog steeds op regel 98 en 146 een foutieve verwijzing, omdat macro
naar mijn mening reageert op Next blad en daardoor elke keer naar een nieuw blad gaat,
terwijl de macro zou moeten stoppen als er op het volgende blad geen data meer staan.
De uitvoering van de macro zou moeten lopen tot en met de regel totaal en daarna
moet het werkblad worden gesaved.
Heb de geteste versie als bijlage bijgevoegd.
Graag reactie en eventueel oplosing
Bvd
Jamara
 
Laatst bewerkt:
Eindelijk opgelost!!??

Nogmaals goedeavond Relleboer,
Ik denk dat ik de oplossing na enig expirimenteren gevonden heb.
Heb bij verwijderen lege regels het navolgende toegevoegd:
If Cells(blad + 1, 1).Value = 0 Then
ActiveWorkbook.SaveAs "C:\Documents and Settings\Jaap\Mijn documenten\Decloverz31072008 test1.xls"
End If
Application.Quit
Bij mij werkt het. Dacht ik, maar toch niet
Goede oplossing of niet laat het me ff weten.
Groetjes,
Jamara
 
Laatst bewerkt:
Heb ff gekeken er naar en ja het is een aardige oplossing. alleen had ik van de 0, empty van gemaakt voor het geval.

Vraag alleen nog ff op opgelost zetten
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan