20.05.2014, 14:46
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
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