AW: Dateien auslesen und kein Ende in Sicht...
23.11.2004 16:44:49
Stefan
Der fEhler liegt hier:
Workbooks.Open .FoundFiles(i), UpdateLinks:=0, ReadOnly:=True
weil die datei die er am anfang identifiziert hat bis zu dem Zeitpunkt wo er sie abarbeiten wollte gelöscht war.
Wenn er jetzt eine datei öffnen will, die nicht da ist steigt er aus.
wenn du den ganzen code willst bitte sehr:
Sub Daten_suchen()
Dim FS As FileSearch, wsh1 As Worksheet, i As Integer, q, c, t, h As String
Set wsh1 = ThisWorkbook.Sheets(1)
Set FS = Application.FileSearch
Let q = 5
With FS
.LookIn = ThisWorkbook.Path
.Filename = "*.xls"
.SearchSubFolders = True
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open .FoundFiles(i), UpdateLinks:=0, ReadOnly:=True
Worksheets(1).Select
If Range("A1") = "Forfaitierungsabrechnung" Then
With wsh1
'Daten kopieren
.Cells(q, 1) = Range("D4")
.Cells(q, 2) = Range("D6")
.Cells(q, 4) = Range("d20")
.Cells(q, 11) = Range("d42")
.Cells(q, 9) = Range("d16")
.Cells(q, 10) = Range("d3")
.Cells(q, 12) = "=e" & q & "/k" & q
.Cells(q, 13) = Range("d14")
.Cells(q, 14) = Range("d13")
If Range("d15") <> "" Then
.Cells(q, 15) = Range("d15")
Else
.Cells(q, 15) = "siehe Zahlungsverpflichteter"
End If
'Kopieren der variablen Daten
If Range("b37") <> "" Then
.Cells(q, 6) = 14
.Cells(q, 7) = Range("b37")
Else
If Range("b36") <> "" Then
.Cells(q, 6) = 13
.Cells(q, 7) = Range("b36")
Else
If Range("b35") <> "" Then
.Cells(q, 6) = 12
.Cells(q, 7) = Range("b35")
Else
If Range("b34") <> "" Then
.Cells(q, 6) = 11
.Cells(q, 7) = Range("b34")
Else
If Range("b33") <> "" Then
.Cells(q, 6) = 10
.Cells(q, 7) = Range("b33")
Else
If Range("b32") <> "" Then
.Cells(q, 6) = 9
.Cells(q, 7) = Range("b32")
Else
If Range("b31") <> "" Then
.Cells(q, 6) = 8
.Cells(q, 7) = Range("b31")
Else
If Range("b30") <> "" Then
.Cells(q, 6) = 7
.Cells(q, 7) = Range("b30")
Else
If Range("b29") <> "" Then
.Cells(q, 6) = 6
.Cells(q, 7) = Range("b29")
Else
If Range("b28") <> "" Then
.Cells(q, 6) = 5
.Cells(q, 7) = Range("b28")
Else
If Range("b27") <> "" Then
.Cells(q, 6) = 4
.Cells(q, 7) = Range("b27")
Else
If Range("b26") <> "" Then
.Cells(q, 6) = 3
.Cells(q, 7) = Range("b26")
Else
If Range("b25") <> "" Then
.Cells(q, 6) = 2
.Cells(q, 7) = Range("b25")
Else
If Range("b24") <> "" Then
.Cells(q, 6) = 1
.Cells(q, 7) = Range("b24")
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
End If
'Kennzeichnung als Erledigt
If .Cells(q, 7) < Date Then
.Cells(q, 8) = "erledigt"
Else
.Cells(q, 8) = "laufend"
End If
End With
Worksheets(2).Select
With wsh1
.Cells(q, 5) = Range("e54")
End With
Let q = q + 1
End If
'Kopieren abgeschlossen
ActiveWorkbook.Close False
Next i
End If
End With
'abschluss der Tabelle
With wsh1
Let q = q - 1
Let t = q + 2
.Cells(t, 1) = "Anzahl:"
.Cells(t, 2) = "=SUBTOTAL(3,B5:B" & q & ")"
.Cells(t, 11) = "Summe:"
.Cells(t, 12) = "=SUBTOTAL(9,L5:L" & q & ")"
End With
MsgBox ("Es wurden " & q - 4 & " Dateien importiert")
End Sub