AW: Laufzeitfehler 13
22.07.2010 13:14:43
JogyB
So, probier das mal aus:
Ich habe es kurz getestet und es funktioniert bei mir. Beim Dateinamen der Log-Files bist Du übrigens relativ frei, es muss nur sichergestellt sein, das eine Sortierung nach Dateinamen die chronologische Reihenfolge ergibt.
Sub daTenKopieren()
Const paTh = "c:\temp\test\" ' hier Deinen Pfad eintragen
Const datNameStart = "xxxx_" ' hier den Anfang Deiner Dateinamen eintragen
Const logDatSp = 31 ' Spalte, in der das Datum in der Logdatei steht
Const suchDatSp = 2 ' Spalte, in der das zu suchende Datum steht
Const firstLogRow = 2 ' erste Zeile in der Log-Datei, in der Werte stehen
Dim daTei As String
Dim zielWsh As Worksheet
Dim quellWsh As Worksheet
Dim dateNr As Long
Dim rowToCopy As Long
Dim i As Long
'1: Wert gefunden
'0: normal suchen
'-1: kann nicht gefunden werden, weil zu alt
'-2: letzte Datei geschlossen, keine Suche mehr
Dim staTe As Integer
On Error GoTo errorHandler
daTei = Dir(paTh & datNameStart & "*")
' wenn es keine Logdateien gibt, dann gleich raus
If daTei = "" Then
MsgBox ("Keine Logdateien vorhanden!")
Exit Sub
' wenn es welche gibt, dann ScreenUpdating aus
' (dann flimmert der Bildschirm nicht)
' sowie die Zielarbeitsmappe und die erste
' Quellarbeitsmappe öffnen
Else
Application.ScreenUpdating = False
Set zielWsh = Workbooks.Add.Sheets(1)
' Überschüssige Sheets löschen
' könnte auch die SheetsInNewWorkbook Eigenschaft ändern,
' aber an solchen Einstellung pfuscht man nur herum,
' wenn es nicht anders geht
With zielWsh.Parent
For i = .Sheets.Count To 2 Step -1
Application.DisplayAlerts = False
.Sheets(i).Delete
Application.DisplayAlerts = True
Next
End With
' Wird schreibgeschützt geöffnet, zur Problemvermeidung
Set quellWsh = Workbooks.Open(paTh & daTei, , True).Sheets(1)
End If
' Läuft über die von Dir eingetragenen Datumswerte
' ich habe mal angenommen, dass die in Zeile 2 starten
' und im ersten Sheet dieser Arbeitsmappe liegen
' ACHTUNG: Diese müssen chronologisch geordnet sein!
With ThisWorkbook.Sheets(1)
For dateNr = 2 To .Cells(Rows.Count, suchDatSp).End(xlUp).Row
If IsDate(.Cells(dateNr, suchDatSp)) Then
' Solange Quelldaten da und im vorigen Durchlauf kein Fehler
While staTe = 0
On Error Resume Next
rowToCopy = _
quellWsh.Columns(logDatSp).Find(.Cells(dateNr, suchDatSp)).Row
' wenn etwas gefunden, dann gibt es keinen Fehler
' also Zeile kopieren
If Err.Number = 0 Then
On Error GoTo errorHandler
quellWsh.Rows(rowToCopy).Copy zielWsh.Rows(dateNr)
staTe = 1
' Bei Fehler schauen, ob das Datum nach dem letzten Datum in der
' aktuell geöffneten Datei
Else
On Error GoTo errorHandler
' falls ja, nächste Datei öffnen, sofern vorhanden
If quellWsh.Cells(Rows.Count, logDatSp).End(xlUp).Value "" Then
Set quellWsh = Workbooks.Open(paTh & daTei, , True).Sheets(1)
Else
Set quellWsh = Nothing
staTe = -2
' Hier braucht kein Fehler eingetragen werden
' passiert weiter unten automatisch
End If
' falls nein, wurde der Wert nicht gefunden
Else
staTe = -1
End If
End If
Wend
' Wenn Fehler oder letzte Datei erreicht, dann Fehlereintrag
If staTe -2 Then staTe = 0
' Wenn es kein Datum war, dann Fehlermeldung in Zieldatei
Else
zielWsh.Cells(dateNr, 1) = _
"''" & .Cells(dateNr, suchDatSp).Text & "' ist kein Datum!"
End If
Next
End With
' Wenn noch eine Quelldatei offen ist (state > -2), dann diese jetzt zu
If staTe > -2 Then quellWsh.Parent.Close False
' ScreenUpdating wieder ein
Application.ScreenUpdating = True
Exit Sub
endOnError:
On Error Resume Next
' Quelldatei zu
quellWsh.Parent.Close False
' Alles was an Applikationseinstellungen geändert wurde wieder zurück
Application.ScreenUpdating = True
Application.DisplayAlerts = True
' Fehlermeldung - ist jetzt nicht sonderlich schön gemacht,
' aber das richtig zu machen ist ein großer Aufwand
MsgBox ("Fehler aufgetreten bei Zeile " & dateNr & " und Datei '" & daTei & "'!" & _
vbNewLine & _
"Fehlermeldung: " & Err.Number & " - " & Err.Description)
Exit Sub
' Muss ich so machen, damit das On Error Resume Next bei endOnError funktioniert
errorHandler:
Resume endOnError
End Sub
Gruß, Jogy