Benachrichtigung bei Fehler in Makro

[friedensbringer]

Hier noch mein komplettes Makro, falls das hilfreich ist...

Ich hätte schon einmal versucht mit "On Error GoTo Fehler" eine Fehlerbehandlung durchzuführen, aber irgendwas mache ich noch falsch,
eventuell das "Exit Sub" an falscher Stelle oder so? Denn danach läuft das Makro die For-Schleife nicht mehr weiter durch...

Danke und lg

Olli

Code:

Sub Makro_03_Kopierfiles_Kopieren()

'    On Error Resume Next
    On Error GoTo Fehler
    Application.Calculation = xlManual 'Berechnung auf manuell schalten
    Application.DisplayAlerts = False 'Fenster mit Meldungen unterdrücken
    
    Dim loi As Long
    Dim dateiname As String
    Dim strFilename As String, strFolder As String
    Dim strOldPath As String, strNewPath As String
    Dim gz As Double 'Gesamtzeit
    Dim ez As Double 'Einzelzeit
    
    gz = Timer 'Timer für Makrodauer starten
    
    'Letzte gefüllte Zeile in Blatt "03-Kopierfiles" Spalte B suchen

    Sheets("03-Kopierfiles").Select
    Calculate
    loletzte = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
    
    'Inhalte, sprich Checkliste in Spalte D löschen
    
    Range("D2:D" & loletzte).Select
    Selection.ClearContents
    
    'Formatierungen in Spalte D erstellen
    
    Columns("D:D").Select
    With Selection
        .HorizontalAlignment = xlCenter
    End With
    
    Range("D2:D" & loletzte).Select
        With Selection.Font
            .Name = "Wingdings"
            .Size = 10
            .Color = -11489280
            .Bold = True
        End With
        
    'Formatierungen in Spalte G erstellen
        
    Columns("G:G").Select
    Selection.NumberFormat = "0.00 ""Minuten"""
    
    'Schleife ab Zeile 2 bis zur letzten Zeile
    For loi = 2 To loletzte 'Cells(Rows.Count, 1).End(xlUp).Row
        
        ez = Timer 'Timer für Makrodauer starten
        
        dateiname = Cells(loi, 2).Value 'Dateiname auslesen
        
        Cells(loi, 2).FormulaR1C1 = dateiname 'Dateiname nochmals als Formel in Zeile schreiben
        
        Cells(loi, 3).Value = Mid(dateiname, Len(dateiname) - InStr(StrReverse(dateiname), ".") + 2) 'Dateiendung auslesen
        
        'Quelldatei (Pfad + Dateiname) ermitteln
        strOldPath = Cells(loi, 2).Text
        
        'Dateiname der Quelldatei ermitteln
        dateiname = Cells(loi, 2).Value
        dateiname = Mid(dateiname, Len(dateiname) - InStr(StrReverse(dateiname), "\") + 2)
        
        'Zielpfad ermitteln
        strFolder = Cells(loi, 5).Text
        
        'Falls erforderlich am Zielpfad ein \ anhängen
        If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
        
        If Sheets("03-Kopierfiles").Cells(loi, 6).Value = "x" Then
        
            'Zieldatei (Pfad + Dateiname) generieren
            
            Date2 = Format(Date, "YYYY.MM.DD")
            
            strNewPath = strFolder & Date2 & "_" & dateiname
        
        Else
        
            'Zieldatei (Pfad + Dateiname) generieren
            strNewPath = strFolder & dateiname
        
        End If
        
            'Kopieren
            FileCopy strOldPath, strNewPath
        
        'Haken setzen wenn Datei geöffnet / neu berechnet und gespeichert wurde
        Range("D" & loi).Select
        ActiveCell.FormulaR1C1 = "þ"
        
Exit Sub
Fehler:
        Range("D" & loi).FormulaR1C1 = ""
        
        Sheets("03-Kopierfiles").Range("G" & loi).Value = Round((Timer - ez) / 60, 2) '& " Sekunden"
    
    Next loi
    
    Windows("Skripte.xlsm").Activate
    
    Sheets("03-Kopierfiles").Range("Z1").Value = Round((Timer - gz) / 60, 2) & " Minuten"
    
    ActiveWindow.ScrollColumn = 2
    Range("B2").Select
    
    Call Schliessen
    
End Sub

[Steffl]

Hallo Olli,

dein Exit Sub ist in jedem Fall an der falschen Stelle. Hast Du die Codes von Karin oder André schon mal getestet?

[Steffl]

Hallo Olli,

ich habe mal den Vorschlag von André in dein Makro integriert und auch Änderungen in deinem Makro gemacht (ein paar Selects entfernt). Bitte füge die Funktion von Andre auch mit ein.

Code:

Sub Makro_03_Kopierfiles_Kopieren()

   '    On Error Resume Next
'   On Error GoTo Fehler
   Application.Calculation = xlManual 'Berechnung auf manuell schalten
   Application.DisplayAlerts = False 'Fenster mit Meldungen unterdrücken
  
   Dim loi As Long
   Dim dateiname As String
   Dim strFilename As String, strFolder As String
   Dim strOldPath As String, strNewPath As String
   Dim gz As Double 'Gesamtzeit
   Dim ez As Double 'Einzelzeit
   Dim intC As Integer
  
   gz = Timer 'Timer für Makrodauer starten
   'Letzte gefüllte Zeile in Blatt "03-Kopierfiles" Spalte B suchen
   Sheets("03-Kopierfiles").Select
   Calculate
   loletzte = IIf(IsEmpty(Cells(Rows.Count, 2)), Cells(Rows.Count, 2).End(xlUp).Row, Rows.Count)
   'Inhalte, sprich Checkliste in Spalte D löschen
   Range("D2:D" & loletzte).ClearContents
   'Formatierungen in Spalte D erstellen
   With Columns("D:D")
      .HorizontalAlignment = xlCenter
   End With
   With Range("D2:D" & loletzte).Font
      .Name = "Wingdings"
      .Size = 10
      .Color = -11489280
      .Bold = True
   End With
   'Formatierungen in Spalte G erstellen
   Columns("G:G").NumberFormat = "0.00 ""Minuten"""
   'Schleife ab Zeile 2 bis zur letzten Zeile
   For loi = 2 To loletzte 'Cells(Rows.Count, 1).End(xlUp).Row
      ez = Timer 'Timer für Makrodauer starten
      dateiname = Cells(loi, 2).Value 'Dateiname auslesen
      Cells(loi, 2).FormulaR1C1 = dateiname 'Dateiname nochmals als Formel in Zeile schreiben
      Cells(loi, 3).Value = Mid(dateiname, Len(dateiname) - InStr(StrReverse(dateiname), ".") + 2) 'Dateiendung auslesen
      'Quelldatei (Pfad + Dateiname) ermitteln
      strOldPath = Cells(loi, 2).Text
      'Dateiname der Quelldatei ermitteln
      dateiname = Cells(loi, 2).Value
      dateiname = Mid(dateiname, Len(dateiname) - InStr(StrReverse(dateiname), "\") + 2)
      'Zielpfad ermitteln
      strFolder = Cells(loi, 5).Text
      'Falls erforderlich am Zielpfad ein \ anhängen
      If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
      If Sheets("03-Kopierfiles").Cells(loi, 6).Value = "x" Then
         'Zieldatei (Pfad + Dateiname) generieren
         Date2 = Format(Date, "YYYY.MM.DD")
         strNewPath = strFolder & Date2 & "_" & dateiname
      Else
         'Zieldatei (Pfad + Dateiname) generieren
         strNewPath = strFolder & dateiname
      End If
      'Kopieren
      'hier eingefügt
      intC = FileOpen(strOldPath)
      If intC = 0 Then
         FileCopy strOldPath, strNewPath
         'Haken setzen wenn Datei geöffnet / neu berechnet und gespeichert wurde
         Range("D" & loi).FormulaR1C1 = "þ"
      End If
      Sheets("03-Kopierfiles").Range("G" & loi).Value = Round((Timer - ez) / 60, 2) '& " Sekunden"
   Next loi
   Windows("Skripte.xlsm").Activate
   Sheets("03-Kopierfiles").Range("Z1").Value = Round((Timer - gz) / 60, 2) & " Minuten"
   Call Schliessen
End Sub


Private Function FileOpen(sPath As String) As Integer
' von André Schau
' nicht gefunden
If Dir(sPath) = "" Then
FileOpen = 2
' gefunden aber?
Else
   On Error GoTo errorhandler
   ' Fehler bei Write wenn schon geöffnet
   ' kommt nicht bei schreibgeschützter Datei
   Open sPath For Random Access Read Lock Read Write As #1
   Close #1
End If
' Exit eigentlich nicht nötig, wenn alles ok gibt's keinen err
Exit Function
errorhandler:
   ' Fehler 70 = File offen
   If Err = 70 Then FileOpen = 1
End Function

[friedensbringer]

Hallo Stefan,

vielen Dank für deine Mühe - werde ich gleich einmal entsprechend einbauen.

lg

Olli