2e gelijke error gaat VBA niet naar de errortrap

Status
Niet open voor verdere reacties.
B

buffalomark

Gebruiker
Lid geworden
12 jun 2007
Berichten
5
Hallo,

Ik heb een vrij uitgebreide macro geschreven voor Excel die door meerdere gebruikers gebruikt wordt. Deze macro geeft regelmatig een foutmelding om 2 redenen.
1. hij probeert een map aan te maken die al bestaat (dit is via de errortrap eenvoudig omzeild).
2. De input van de gebruikers is niet juist. Dit kan ook niet anders, dus ook daar is een errortrap voor geschreven.

Error 1 gebeurt een aantal keer gedurende het proces en werkt goed.
If Err.Number = 75 Then
Resume Next

Als error 2 zich voordoet wordt dit ook correct verwerkt (De macro vervangt dan alle foute input door de juiste die de gebruiker dmv een invulscherm kan invullen).

Wanneer error 2 echter nogmaals gebeurt, geeft VBA een foutmelding zonder dat hij naar de errortrap gaat. De code is mij onbekend en heb ik ook nog niet kunnen vinden (erg lang nummer en bij een derde fout geeft hij weer een heel ander nummer aan).

Heeft iemand een idee hoe dit zou kunnen komen?
 
Met

Code: 
if dir("C:\bestaande map",16)="" then

vermijd je het genereren en verwerken van een err.number.

Het is niet moeilijk invoerfouten van een gebruiker te voorkomen wanneer je de gebruiker keuzes laat maken in plaats van gegevens invoeren.
 
Bedankt voor de code. Deze kan ik gebruiken.

Het probleem is dat gebruikers niet direct gegevens invoert, maar er worden twee grote bestanden gekoppeld. Aan de ene kant een lijst met medewerkers (7000) en hun gegevens en aan de andere kant een lijst met verantwoordelijken (zo'n 400) waar de verschillende gegevens naar toe moeten. De macro koppelt de medewerkergegevens en de verantwoordelijke en creëert dan bestanden die via outlook verstuurt worden.
Het bestand met verantwoordelijken wordt onderhouden, maar regelmatig komt het voor dat de namen en/of e-mailadressen in outlook wisselen zonder dat men er op de administratie vanaf weet. Dit is op korte termijn ook niet te wijzigen.

De vraag is echter hoe het kan dat vba de ene keer met dezelfde fout wel naar de errortrap gaat en de tweede keer niet? Heb je enig idee?
 
Zonder hier iets van de code te plaatsen is dat niet te zeggen.
Dit is geen helderziendenforum.
 
hierbij de code. normaal gesproken gaat het om 6 loops, maar ik heb er 2 in laten staan ter verduidelijking.



Code: 
Sub Distributie_ziekenlijst()
'
' Distributie_ziekenlijst Macro
' De macro is opgenomen op 29-9-2007 door ....
'
    On Error GoTo Errortrap
    Dim varAnswer As String

    varAnswer = MsgBox("Het versturen van de ziekenlijst neemt tijd in beslag. Weet je zeker dat je door wilt gaan met het versturen?", vbYesNo, "Let op!")
    If varAnswer = vbNo Then
    ActiveWindow.Close savechanges = False
        Exit Sub
    
    
    End If
    MsgBox "Wanneer je de procedure voortijdig wilt beëindigen, gebruik dan de toetscombinatie CTRL + Break", vbinfo, "Tip"
    
    'zichtbare sheet tijdens procedure
    Sheets("Wachten").Visible = True
    Sheets("Wachten").Select
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    
    
  
    'Kopieer de gegevens uit het ziekenlijst
    Range("A1:I1000").Select
    Selection.Copy
    Windows("Distributie ziekenlijst.xls").Activate
    Sheets("Blad1").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Windows("Actueel ziekenlijst.xls").Activate
    ActiveWindow.Close savechanges = False
    
    ' Kopieer de gegevens uit het distributiebestand

    ChDir _
        "j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\"
    Workbooks.Open Filename:= _
        "j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\distributielijst ziekenlijst.xls"
    Cells.Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Distributie ziekenlijst.xls").Activate
    Sheets("Blad2").Select
    Cells.Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Windows("distributielijst ziekenlijst.xls").Activate
    ActiveWindow.Close savechanges = False
    
    'Maak de verticaal zoeken functies
    Sheets("Blad1").Select
    Range("J2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-9],Blad2!C[-9]:C[-2],3,FALSE)"
    Range("J2").Select
    Selection.AutoFill Destination:=Range("J2:J1000")
    
    Range("K2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-10],Blad2!C[-10]:C[-3],4,FALSE)"
    Range("K2").Select
    Selection.AutoFill Destination:=Range("K2:K1000")


    'Geef de Kolommen met distributienamen een titel voor gebruik van de draaitabel
    Sheets("Blad1").Select
    Range("J1").Select
    ActiveCell.FormulaR1C1 = "1e naam"
    Range("K1").Select
    ActiveCell.FormulaR1C1 = "2e naam"


    'Maak van alle formules vaste waarden
    Sheets("Blad1").Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False

    'Maak de draaitabellen van de distributielijsten
    Sheets("Blad3").Select
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "Blad1!J:J").CreatePivotTable TableDestination:= _
        "'[Distributie ziekenlijst.xls]Blad3'!R3C3", TableName:="Draaitabel14", _
        DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTables("Draaitabel14").AddDataField ActiveSheet.PivotTables( _
        "Draaitabel14").PivotFields("1e naam"), "Aantal van 1e naam", xlCount
    ActiveWorkbook.ShowPivotTableFieldList = False
    With ActiveSheet.PivotTables("Draaitabel14").PivotFields("1e naam")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveWorkbook.ShowPivotTableFieldList = False

    Sheets("Blad3").Select
    Range("F3").Select
    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
        "Blad1!K:K").CreatePivotTable TableDestination:= _
        "'[Distributie ziekenlijst.xls]Blad3'!R3C6", TableName:="Draaitabel15", _
        DefaultVersion:=xlPivotTableVersion10
    ActiveSheet.PivotTables("Draaitabel15").AddDataField ActiveSheet.PivotTables( _
        "Draaitabel15").PivotFields("2e naam"), "Aantal van 2e naam", xlCount
    With ActiveSheet.PivotTables("Draaitabel15").PivotFields("2e naam")
        .Orientation = xlRowField
        .Position = 1
    End With
    ActiveWorkbook.ShowPivotTableFieldList = False
    
    'maak van de draaitabellen vaste waarden
    Sheets("Blad3").Select
    Cells.Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    
    'Maak een autofilter aan
    Sheets("Blad1").Select
    Rows("1:1").Select
    Selection.AutoFilter

    'alle dims
    Dim wb As Workbook
    Dim sNewName As String
    Dim fName As String
    Dim FSubName As String
    Dim strnaam As String
    Dim out As Outlook.Application
    Dim mailtje As Outlook.MailItem

    'maak een nieuwe folder
    
    fName = Workbooks("Distributie ziekenlijst.xls").Sheets("Blad3").Range("B3").Value
    MkDir ("j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\" & fName & "\")
    
    FSubName = Workbooks("Distributie ziekenlijst.xls").Sheets("Blad3").Range("B6").Value
    MkDir ("j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\" & fName & "\" & FSubName & "\")


    'verstuur de gegevens naar de lijst 1e naam
10 Do Until Sheets("blad3").Range("C5").Value = "#N/B"
    If Sheets("blad3").Range("C5").Value = "0" Then
        Sheets("blad3").Range("C5").Delete Shift:=xlUp
    End If
    Sheets("Blad1").Select
    Selection.AutoFilter Field:=10, Criteria1:=Sheets("blad3").Range("C5")
    Range("A1:O1000").Copy
    
    'Maak een nieuw bestand aan.
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Cells.Select
    Selection.ColumnWidth = 50.14
    ActiveSheet.Cells.EntireColumn.AutoFit
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Columns("J:O").Select
    Selection.EntireColumn.Hidden = True
        Sheets("Blad3").Select
    AddIns("Analysis ToolPak - VBA").Installed = True
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "=weeknum(TODAY(),1)"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "week "
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,R[-2]C,)"
        Sheets("Blad1").Select
    
    sNewName = "j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\" & fName & "\" & FSubName & "\ziekenlijst " & ActiveSheet.Range("J2") & ".xls"
    ActiveWorkbook.SaveCopyAs sNewName
       
    'Maak een e-mail met het bestand
       
    Set out = Outlook.Application
    Set mailtje = out.CreateItem(olMailItem)
    mailtje.Subject = "Ziekenlijst " & Sheets("blad3").Range("B6") & " "
    mailtje.Body = "Beste collega," & vbNewLine & vbNewLine & _
    "Bijgaand vind je het overzicht van de actueel zieken van deze week." & vbNewLine & _
    "Voor overige vragen kan je deze email beantwoorden of via onderstaand telefoonnummer contact met ons opnemen." & vbNewLine & vbNewLine & _
    "Met vriendelijke groeten," & vbNewLine & _
    "P&O Desk" & vbNewLine & vbNewLine & _
    "E-mail      blabla@bla.nl" & vbNewLine & _
    "Post        Utrecht B05.39" & vbNewLine & _
    "Telefoon    030 - 111111" & vbNewLine & _
    "Fax         030 - 111111" & vbNewLine & _
    " "
    mailtje.To = Sheets("blad1").Range("J2")
        'mailtje.SenderEmailAddress = "SC P&O Desk"
    mailtje.Attachments.Add sNewName
    'mailtje.Sensitivity = olPrivate
    'mailtje.Close olSave
    mailtje.Send

    ' Maak de gegevens klaar voor de volgende naam op de distributielijst van 1e naam
    ActiveWorkbook.Close savechanges:=False
    Sheets("blad1").ShowAllData
    Sheets("blad3").Range("C5").Delete Shift:=xlUp
    Loop

    Sheets("Wachten").Range("E5").Value = "De 1e kolom met namen is verwerkt"
    Sheets("Wachten").Select
    Application.ScreenUpdating = True
    Application.ScreenUpdating = False

    'verstuur de gegevens naar de lijst 2e naam
    Do Until Sheets("blad3").Range("F5").Value = "#N/B"
    If Sheets("blad3").Range("F5").Value = "0" Then
        Sheets("blad3").Range("F5").Delete Shift:=xlUp
    End If
    Sheets("Blad1").Select
    Selection.AutoFilter Field:=11, Criteria1:=Sheets("blad3").Range("F5")
    Range("A1:O1000").Copy
    
    'Maak een nieuw bestand aan.
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Cells.Select
    Selection.ColumnWidth = 50.14
    ActiveSheet.Cells.EntireColumn.AutoFit
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
    :=False, Transpose:=False
    Columns("J:O").Select
    Selection.EntireColumn.Hidden = True
        Sheets("Blad3").Select
    AddIns("Analysis ToolPak - VBA").Installed = True
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "=weeknum(TODAY(),1)"
    Range("B5").Select
    ActiveCell.FormulaR1C1 = "week "
    Range("B6").Select
    ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-1]C,R[-2]C,)"
        Sheets("Blad1").Select
    
    sNewName = "j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\" & fName & "\" & FSubName & "\ziekenlijst " & ActiveSheet.Range("K2") & ".xls"
    ActiveWorkbook.SaveCopyAs sNewName
       
    'Maak een e-mail met het bestand
       
    Set out = Outlook.Application
    Set mailtje = out.CreateItem(olMailItem)
    mailtje.Subject = "Ziekenlijst " & Sheets("blad3").Range("B6") & " "
    mailtje.Body = "Beste collega," & vbNewLine & vbNewLine & _
    "Bijgaand vind je het overzicht van de actueel zieken van deze week." & vbNewLine & _
    "Voor overige vragen kan je deze email beantwoorden of via onderstaand telefoonnummer contact met ons opnemen." & vbNewLine & vbNewLine & _
    "Met vriendelijke groeten," & vbNewLine & _
    "P&O Desk" & vbNewLine & vbNewLine & _
    "E-mail      blabla@bla.nl" & vbNewLine & _
    "Post        Utrecht B05.39" & vbNewLine & _
    "Telefoon    030 - 111111" & vbNewLine & _
    "Fax         030 - 111111" & vbNewLine & _
    " "
    mailtje.To = ActiveSheet.Range("K2")
        'mailtje.SenderEmailAddress = "SC P&O Desk"
    mailtje.Attachments.Add sNewName
    'mailtje.Sensitivity = olPrivate
    'mailtje.Close olSave
    mailtje.Send
    
    ' Maak de gegevens klaar voor de volgende naam op de distributielijst van 2e naam
    ActiveWorkbook.Close savechanges:=False
    Sheets("blad1").ShowAllData
    Sheets("blad3").Range("F5").Delete Shift:=xlUp
    Loop
    
    Sheets("Wachten").Range("E6").Value = "De 2e kolom met namen is verwerkt"
    Sheets("Wachten").Select
    Application.ScreenUpdating = True
    Application.ScreenUpdating = False
    
   ' hierna geen loops meer

    sNewName = "j:\P&O Algemeen\Lijstwerk\Lijstwerk Business\Actuele Zieken\2008\" & fName & "\Gehele ziekenlijst " & Sheets("blad3").Range("B6") & ".xls"
    ActiveWorkbook.SaveCopyAs sNewName

    Sheets("blad2").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("blad1").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("blad3").Select
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "=CEILING((((NOW())-R[-1]C)/R[1]C)/60,0.5)"
    Selection.NumberFormat = "1"
    Range("A5").Select
    ActiveCell.FormulaR1C1 = "0:00:01"
    MsgBox "Alle lijsten zijn gemaakt en zijn verstuurd. Het verwerken heeft ongeveer " & Range("A4") & " minuten geduurd.", vbInformation
    Cells.Select
    Selection.ClearContents
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    Selection.Borders(xlEdgeLeft).LineStyle = xlNone
    Selection.Borders(xlEdgeTop).LineStyle = xlNone
    Selection.Borders(xlEdgeBottom).LineStyle = xlNone
    Selection.Borders(xlEdgeRight).LineStyle = xlNone
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("A1").Select
    
    Sheets("Wachten").Select
    Range("E5:E10").Clear
    Range("A1").Select
    
    Sheets("Wachten").Visible = False
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
    ActiveWindow.Close savechanges = False

Exit Sub

Errortrap:
   'als de nieuwe folder al bestaat, dan overslaan
   If Err.Number = 75 Then
   Resume Next
Else
    'als een naam uit de distributielijst niet klopt, dan de naam nakijken
    ActiveWorkbook.Close savechanges:=False
    Windows("Distributie ziekenlijst.xls").Activate
    Sheets("Blad3").Select
    Range("C5").Copy
    Range("A7").PasteSpecial
    Range("F5").Copy
    Range("A8").PasteSpecial
    Range("I5").Copy
    Range("A9").PasteSpecial
    Range("L5").Copy
    Range("A10").PasteSpecial
    Range("O5").Copy
    Range("A11").PasteSpecial
    Range("R5").Copy
    Range("A12").PasteSpecial
    
    If Sheets("blad3").Range("A7").Value = "#N/B" Then
        Sheets("blad3").Range("A7").Delete Shift:=xlUp
    End If
    If Sheets("blad3").Range("A7").Value = "#N/B" Then
        Sheets("blad3").Range("A7").Delete Shift:=xlUp
    End If
    If Sheets("blad3").Range("A7").Value = "#N/B" Then
        Sheets("blad3").Range("A7").Delete Shift:=xlUp
    End If
    If Sheets("blad3").Range("A7").Value = "#N/B" Then
        Sheets("blad3").Range("A7").Delete Shift:=xlUp
    End If
    If Sheets("blad3").Range("A7").Value = "#N/B" Then
        Sheets("blad3").Range("A7").Delete Shift:=xlUp
    End If
        
    'verkeerde naam vervangen door de juiste
    Dim ZoekString As String
    Dim VervangString As String
    
    ZoekString = Range("A7")
    
    Application.Cursor = xlDefault

    VervangString = InputBox("De volgende naam uit de distributielijst komt niet overeen met een naam in Outlook." & vbNewLine & vbNewLine & _
    Range("A7") & vbNewLine & vbNewLine & "Vul hier de juiste naam in, zoals deze ook in Outlook staat vermeld.", "Naam vervangen", "Vul hier de nieuwe naam in")
    
    If VervangString = Cancel Then
    MsgBox "Er is een fout opgetreden waardoor niet alle lijsten zijn gemaakt en verzonden." & vbNewLine & vbNewLine & _
           "Neem contact op met de beheerder van de macro om het probleem op te lossen.", vbInformation, "Foutmelding!"
    
    Sheets("Wachten").Visible = True
    Sheets("Wachten").Select
    Range("E5:E10").ClearContents
    Range("A1").Select
    Sheets("Wachten").Visible = False

    Application.ScreenUpdating = True

    Exit Sub
    End If
    
    Cells.Replace What:=ZoekString, Replacement:=VervangString, LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
 
    Sheets("Blad1").Select
    Cells.Replace What:=ZoekString, Replacement:=VervangString, LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
    Sheets("Blad2").Select
    Cells.Replace What:=ZoekString, Replacement:=VervangString, LookAt:=xlPart, SearchOrder _
        :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
    Sheets("Blad3").Select
    Range("A7:A12").Clear
        
    MsgBox "De naam is nu vervangen en het verzenden van de lijst zal verder gaan." & vbNewLine & vbNewLine & _
           "Vergeet de naam niet ook te vervangen in de distributielijst, zodat deze melding niet weer voorkomt.", vbInformation, "Opgelost!"
    Application.Cursor = xlWait

    GoTo 10

End If
    
End Sub
 
1. Vermijd select en activate in VBA; die zijn overbodig en vertragend.
2. voorkom het genereren van foutcodes, die zijn traag
3. de code kan véél korter en sneller.
4. als je een foutafhandeling wil gebruiken, maak dan voor iedere potentiële fout een afzonderlijke procedure
5. duid ieder bereik aan met workbook(x).sheets(y).range(z) en niet met range(z). Dat voorkomt fouten.

Voorbeeld van ingekorte code
Code: 
  On Error GoTo Fout1

  If  MsgBox("Het versturen van de ziekenlijst neemt tijd in beslag. Weet je zeker dat je door wilt gaan met het versturen?", vbYesNo, "Let op!") = vbNo Then  Exit Sub
  MsgBox "Wanneer je de procedure voortijdig wilt beëindigen, gebruik dan de toetscombinatie CTRL + Break", vbinfo, "Tip"
  'Kopieer de gegevens uit de ziekenlijst
  Workbooks(x).sheets(y).Range("A1:I1000").Copy Workbooks("Distributie ziekenlijst.xls").Sheets("Blad1").Range("A1")
 
Bedankt voor de tips,

Ik vraag me af of deze aanpassingen echter helpen om de fout te verhelpen. De macro werkt immers op dit moment ook goed totdat hij een tweede keer dezelfde fout constateert. Heeft iemand dat eerder meegemaakt?
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan