Hi,
sieht schon super gut aus, ansich funktioniert es einwandfrei, allerdings sind nun 2 neue Probleme aufgetaucht:
1. Excel wackelt ;-)) fürchterlich ... man sieht also, dass etwas passiert, ich habe Application.DisplayAlerts = False eingefügt ... doch garantiert wieder an der falschen Stelle ...
2. Es werden auch leere Datensätze übernommen (das hatte ich vorher gar nicht bedacht). Es existieren Tabellen, in denen keine Daten vorhanden sind, diese brauchen dann ja auch gar nicht übertragen werden.
Also brauche ich eine If-Abfrage ... mein Ansatz wäre
If ActiveSheet.Range("B10") = "" Then
doch dann?? es soll ja kein Abbruch erfolgen??
Hier der geänderte Code:
Option Explicit
Const strPath = "C:\Users\Petra\Desktop\Behandlungen"
Sub Dateien_auslesen()
Dim Datei$
Dim lngFirstRow As Long
Dim lngLastRow As Long
Dim lngCopyRow As Long
[A5:k65000] = "" 'Alte Eintragungen löschen
Datei = Dir(strPath & "\*.xls")
Application.AskToUpdateLinks = False 'deaktiviert Aktualisierung
Do While Datei <> ""
Application.DisplayAlerts = False 'HIER oder WO ???
If Right(Datei, 4) = ".xls" Then
GetObject (strPath & "\" & Datei)
lngFirstRow = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
lngLastRow = Workbooks(Datei).Sheets(1).Cells(Rows.Count, 2).End(xlUp).Row
lngCopyRow = lngFirstRow + (lngLastRow - 10)
With Workbooks(Datei).Sheets(1)
If ActiveSheet.Range("B10") = "" Then
'??????? .Range("B10:H" & lngLastRow).Copy ActiveSheet.Cells(lngFirstRow, 5) 'Behandlungsdaten
ActiveSheet.Range("A" & lngFirstRow & ":A" & lngCopyRow) = .Range("C3") 'Kundennummer
ActiveSheet.Range("B" & lngFirstRow & ":B" & lngCopyRow) = .Range("C4") 'Nachname
ActiveSheet.Range("C" & lngFirstRow & ":C" & lngCopyRow) = .Range("C5") 'Vorname
ActiveSheet.Range("D" & lngFirstRow & ":D" & lngCopyRow) = .Range("C6") 'Abrechnung
End With
Workbooks(Datei).Close
End If
Datei = Dir()
Loop
Application.DisplayAlerts = True
End Sub