Sub ImportCSV(Dateiname, ZielTabelle As String)
Dim rFind As Range, FallNr, Patient
Dim AC As Range, FinalRow As Long
Dim AR As Worksheet, zAr, zCS As Long
Dim WS As Worksheet, j, c, n, x As Long
If Dateiname = False Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets.Add.Name = "CSV"
Set WS = ThisWorkbook.Sheets("CSV")
Workbooks.Open Filename:=Dateiname, Local:=True
ActiveSheet.UsedRange.Copy WS.Cells(1)
ActiveWorkbook.Close SaveChanges:=False
On Error GoTo Fehler
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
With Worksheets("Aktuell stationär")
'Patienten Daten Spalte O-T zum wiederherstellen retten
WS.Range("BA2:BZ200").ClearContents
'Druckblatt 1-4 Daten in CSV Sheet retten zum wiederherstellen!
.Range("K2:T100").Copy
WS.Range("BA2").PasteSpecial xlPasteValues
zCS = WS.Cells(Rows.Count, "BA").End(xlUp).Row + 2
.Range("U2:AD100").Copy
WS.Range("BA" & zCS).PasteSpecial xlPasteValues
zCS = WS.Cells(Rows.Count, "BA").End(xlUp).Row + 2
.Range("AE2:AN100").Copy
WS.Range("BA" & zCS).PasteSpecial xlPasteValues
zCS = WS.Cells(Rows.Count, "BA").End(xlUp).Row + 2
.Range("AO2:AX100").Copy
WS.Range("BA" & zCS).PasteSpecial xlPasteValues
Application.CutCopyMode = False
'Druckblatt 1-4 Spalte O-T löschen
.Range("O2:T100").ClearContents
.Range("Y2:AD100").ClearContents
.Range("AI2:AN100").ClearContents
.Range("AS2:AX100").ClearContents
'** Datenverarbeitung - alte Daten öschen, neue Daten einfügen
Set AR = ThisWorkbook.Sheets("Archiv")
'Nächste freie Zeile in Aktuell und Archiv suchen
zAr = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
'LastZell in "Aktuell stationär" suchen
FinalRow = .Cells(Rows.Count, 1).End(xlUp).Row
'dann Prüfen ob Datensätze erloschen sind -> ins Archiv verschieben
For x = 2 To FinalRow
FallNr = .Cells(x, 6) 'Fall Nummer in Spalte F "CSV" Tabelle suchen
Set rFind = WS.Columns(6).Find(What:=FallNr, After:=WS.[f1], LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
'Gefunden Datensatz mit neuesten Daten überschreiben
If Not rFind Is Nothing Then
WS.Cells(rFind.Row, 1).Resize(1, 10).Copy
.Cells(x, 1).PasteSpecial xlPasteValues
End If
'Nicht gefunden Datensatz ins Archiv kopieren und löschen
If rFind Is Nothing Then
.Cells(x, 1).Resize(1, 10).Copy
AR.Cells(zAr, 1).PasteSpecial xlPasteValues
'Datensatz nur Spalte A-J löschen!!
.Cells(x, 1).Resize(1, 10).ClearContents
zAr = zAr + 1: c = c + 1
End If
Next x
'evtl. Leerzeilen in "Aktuell stationär" rückwärts löschen
If c > 0 Then
For x = FinalRow To 2 Step -1
If .Cells(x, 1) = Empty Then
.Cells(x + 1, 1).Resize(FinalRow - x + 3, 10).Copy
.Cells(x, 1).PasteSpecial xlPasteValues
End If
Next x
End If
'zuerst neue CSV Datensätze in "Aktuell stationär" unten anhängen
FinalRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
zCS = .Cells(Rows.Count, 1).End(xlUp).Row + 1
For x = 2 To FinalRow
FallNr = WS.Cells(x, 6) 'Fall Nummer in Spalte F "Aktuell stationär" suchen
Set rFind = .Columns(6).Find(What:=FallNr, After:=.[f1], LookIn:=xlFormulas, LookAt:= _
xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
'neue CSV Datensätze in "Aktuell stationär" übernehmen
If rFind Is Nothing Then
'neue CSV Daten in Aktuell kopieren
WS.Cells(x, 1).Resize(1, 10).Copy
.Cells(zCS, 1).PasteSpecial xlPasteValues
zCS = zCS + 1: n = n + 1
End If
Next x
'Daten für dem wiederherstellen nach Raum sortieren
Range("A2:J100").Sort Key1:=Range("J2"), Order1:=xlAscending, Header:= _
xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'** vor dem wiederherstellen Formeln neu berechen!!
Application.Calculation = xlCalculationAutomatic
Application.Calculate 'noch mal deaktivieren
Application.Calculation = xlCalculationManual
'** Patienten Daten O-T in Druckblatt 1-4 wiederherstellen
'gerettete Patienten Daten aus Spalte O-T wieder einfügen
FinalRow = WS.Cells(Rows.Count, "BA").End(xlUp).Row
For x = 2 To FinalRow
If WS.Cells(x, "BA") Empty Then
Patient = WS.Cells(x, "BA") 'Patienten Text in "Aktuell stationär" suchen
Set rFind = .Cells.Find(What:=Patient, After:=.[k1], LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
'frühere Patientendaten in "Aktuell stationär" wieder einfügen
If Not rFind Is Nothing Then
WS.Cells(x, "BE").Resize(1, 6).Copy
.Cells(rFind.Row, rFind.Column + 4).PasteSpecial xlPasteValues
End If
End If
Next x
'ggf. Patientendaten O-T im Archiv einfügen
If c > 0 Then
zAr = zAr - 1
For j = zAr - c To zAr
For x = 2 To FinalRow
Patient = WS.Cells(x, "BA")
If InStr(Patient, AR.Cells(j, 1)) And _
InStr(Patient, AR.Cells(j, 2)) Then
'neue CSV Daten in Aktuell k6opieren
WS.Cells(x, "BE").Resize(1, 6).Copy
AR.Cells(j, 15).PasteSpecial xlPasteValues
End If
Next x
Next j
End If
End With
Ende: 'Applicationen wieder aktivieren
Application.Calculation = xlCalculationAutomatic
Application.CutCopyMode = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Sheets("Aktuell stationär").Select
Range("K1").Select
If Err > 0 Then Exit Sub
MsgBox n & " neue Datensätze" & vbLf & c & " Datensätze gelöscht"
Exit Sub
Fehler: 'bei Fehler Application aktivieren
MsgBox "unerwartete Fehler aufgetreten & vblf & Error()": GoTo Ende
End Sub