Live-Forum - Die aktuellen Beiträge
Datum
Titel
17.06.2024 19:56:24
17.06.2024 19:39:46
Anzeige
Archiv - Navigation
1872to1876
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA Probleme bei csv Import

VBA Probleme bei csv Import
22.02.2022 16:26:48
Setre
Hallo liebe Excel-Gemeinde,
ich stehe vor folgendem Problem:
Ich möchte aus einer csv Datei, die eine Personenliste mit verschiedenen Infos enthält, diese Daten in Excel kopieren und dann in weiteren Spalten Zusatzinformationen sozusagen "per Hand" nachtragen. Die Personenliste ändert sich jeden Tag, manche Personen bleiben, andere sind nicht mehr auf der Liste, manchmal kommen neue hinzu. Jede Person auf der Liste hat eine einmalige, individuelle Nummer.
Ich habe das Programm aktuell so aufgebaut:
Die CSV Daten werden aus einem gesonderten Arbeitsblatt in die Spalten A-J kopiert.
In den Spalten K-N habe ich bestimmte Daten aus den Spalten A-J mit Excelformeln übernommen (Im finalen Ausdruck blende ich dann Spalten A-J aus).
In den Spalten O-T befinden sich zu jeder Person (jede Person ist eine Zeile) bestimmte Zusatzinformationen, die ich per Hand aus einem anderen Programm eintragen muss.
Das Makro kann aktuell, wenn eine neue CSV Datei importiert wird, überprüfen, ob die Fallnummer in der Spalte F identisch ist mit der schon gespeicherten und kopiert nur bei Änderungen, und die Zusatzinfos aus Spalten O-T werden dann gelöscht.
Wenn jetzt aber in der Ursprungsdatei eine Person aus der Mitte der Liste gelöscht wird, und alle anderen sozusagen hoch rutschen, funktioniert das Makro nicht mehr, weil dann darunter auch wieder "alte" Personen importiert werden und die Zusatzinfos gelöscht werden, obwohl die Personen sozusagen nur um eine Zeile verrutscht sind.
Nun habe ich zwei Fragen:
1: Wie kann ich Excel klarmachen, dass die nachgetragenen Zusatzinfos aus Spalten O-T zu genau dieser Fallnummer aus der entsprechenden Zeile gehören?
2: Kann ich mein Makro abändern, dass quasi jedes Mal alle Fallnummern auf Duplikate überprüft werden, und nur Zeilen neu importiert werden, die es noch nicht gibt, und alle anderen Zeilen (Personen), die nicht mehr auf der neuen Liste sind, dann aus der Excel Datei gelöscht werden.
Über eure Hilfe würde ich mich sehr freuen!
Vielen Dank im Voraus!
LG
Hier das Programm zum jetzigen Zeitpunkt (PS: Meistens befinden sich nicht mehr als 20 Personen auf der Liste, also lasse ich am Ende bei nlz = lz + 30 einfach mal 30 Zeilen unterhalb der letzten löschen, für eine elegantere Lösung bin ich natürlich auch sehr dankbar!):

Sub ImportCSV(Dateiname, ZielTabelle As String)
If Dateiname  False Then
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim Ws As Worksheet
Sheets.Add.Name = "CSV"
Set Ws = ActiveWorkbook.Sheets("CSV")
Workbooks.Open FileName:=Dateiname, Local:=True
ActiveSheet.UsedRange.Copy Ws.Cells(1)
ActiveWorkbook.Close SaveChanges:=False
Sheets("CSV").Select
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For x = 2 To FinalRow
ThisValue = Cells(x, 6).Value
If ThisValue  Sheets("Aktuell").Cells(x, 6).Value Then
Range(Cells(x, 1), Cells(x, 10)).Copy
Sheets("Aktuell").Select
Range(Cells(x, 1), Cells(x, 10)).Select
ActiveSheet.Paste
Sheets("Aktuell").Range(Cells(x, 15), Cells(x, 20)).ClearContents
Sheets("CSV").Select
Else
End If
Next x
Dim lz As Integer
Dim nlz As Integer
lz = ActiveSheet.UsedRange.Rows.Count + 1
nlz = lz + 30
Sheets("Aktuell").Select
Range(Cells(lz, 1), Cells(nlz, 10)).Select
Selection.ClearContents
Range(Cells(lz, 15), Cells(nlz, 20)).Select
Selection.ClearContents
Sheets("CSV").Delete
Sheets("Aktuell").Range("K1").Select
Else
End If
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub StartImportCSV()
Dim fileToOpen As String
ChDrive "H"
fileToOpen = Application.GetOpenFilename(FileFilter:="CSV Dateien (*.csv), *.csv", Title:="Exportierte .csv Datei öffnen")
ImportCSV fileToOpen, "CSV Import"
End Sub

25
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Probleme bei csv Import
23.02.2022 09:38:26
Herbert_Grom
Hallo Pepi,
um dir helfen zu können, musst du uns schon deine beiden Dateien hochladen!
Servus
AW: VBA Probleme bei csv Import
23.02.2022 15:18:34
Setre
Tut mir Leid, habe ich vergessen.
Die Dateien gibt es hier:
https://www.herber.de/bbs/user/151320.xlsm
Und die CSV Datei konnte ich leider hier nicht hochladen, deswegen habe ich einen Screenshot als jpg gemacht:
Userbild
AW: VBA Probleme bei csv Import
24.02.2022 12:07:29
Piet
Hallo
bitte mal dieses geänderte Makro in einer Kopie Datei testen. Bitte NICHT in der Originaldatei!!
In neuen Makros, das ich nicht testen konnte, könnnen immer Fehler enthalten sein. Deshalb bitte in einer Kopie Datei testen ob alles einwandfrei klappt.
Dieses Makro benötigt eine neue Tabelle mit dem Namen "Archiv"! Alle erloschenen Datensätze werden zuerst ins Archiv verschoben und in "Aktuell" gelöscht!
Danach kopiere ich nur die neu hinzugekommenen Datensätze. Die bereits bestehenden sollte man nicht verändern. Es sei denn einige Daten haben sich geändert!
Dann muss ich das noch mal nacharbeiten. Mich interessiert aber ob diese Version einwandfrei funktioniert. Nacharbeiten ist kein Thema ....
mfg Piet
  • Option Explicit
    
    Sub ImportCSV(Dateiname, ZielTabelle As String)
    Dim rFind As Range, FallNr As Variant
    Dim AC As Range, FinalRow As Long
    Dim WS As Worksheet, c, x As Long
    Dim AR As Worksheet, n, z As Long
    If Dateiname  False Then
    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
    With Worksheets("Aktuell stationär")
    Set AR = ThisWorkbook.Sheets("Archiv")
    'Nächste freie Zeile in Archiv suchen
    z = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'zuerst Prüfen ob Datensätze erloschen sind -> ins Archiv verschieben
    For x = 2 To FinalRow
    If .Cells(x, 6).End(xlDown).Row > FinalRow Then Exit For
    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)
    'Nicht gefunden Datensatz ins Archiv kopieren und löschen
    If rFind Is Nothing Then
    .Rows(x).Copy AR.Rows(z)     'ins Archiv kopieren
    .Rows(x).Delete shift:=xlUp  'Datensatz löschen
    z = z + 1:  x = x - 1:  c = c + 1
    End If
    Next x
    'Nächste freie Zeile in Archiv suchen
    z = .Cells(Rows.Count, 6).End(xlUp).Row + 1
    'Prüfen ob neue Datensätze in CSV vorhanden sind
    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 Datensätze ins "Aktuell stationär" unten anhängen
    If rFind Is Nothing Then
    WS.Rows(x).Copy .Rows(z)     'ins "Aktuell stationär" kopieren
    z = z + 1:  n = n + 1        '** unten anhängen!!
    End If
    Next x
    End With
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("Aktuell stationŠr").Select
    Range("K1").Select
    MsgBox n & "  neue Datensätze" & vbLf & c & "  Datensätze gelöscht"
    End Sub
    

    
    Sub StartImportCSV()
    Dim fileToOpen As String
    fileToOpen = Application.GetOpenFilename()
    ImportCSV fileToOpen, "CSV Import"
    End Sub
    

  • Anzeige
    AW: VBA Probleme bei csv Import
    24.02.2022 12:11:28
    Piet
    Nachtrag offenstellen vergessen
    wenn bei bestehenden Datensätzen noch Spalten aus der CSV Datei kopiert werden müssen um welche Spalten handelt es sich, und kann man die 1:1 nach "Aktuell" kopieren?
    mfg Piet
    AW: VBA Probleme bei csv Import
    24.02.2022 12:44:51
    Setre
    Super, vielen Dank schon einmal für die ganze Arbeit!!
    Leider klappt das Makro noch nicht, es importiert keine Dateien in die Tabelle Aktuell.
    Die Spalten O - T sollen beibehalten werden, wenn es sich um die gleiche Person handelt, ansonsten können sie gelöscht werden.
    AW: VBA Probleme bei csv Import
    24.02.2022 13:12:40
    Piet
    Hallo
    okay, habs verstanden, werde es ändern. Heute habe ich aber keine Zeit mehr dafür.
    mfg Piet
    Anzeige
    AW: VBA Probleme bei csv Import
    24.02.2022 14:23:04
    Setre
    Kein Problem,
    super, danke nochmal!!
    AW: VBA Probleme bei csv Import
    25.02.2022 12:34:50
    Piet
    Hallo
    schau bitte mal ob es mit diesem Makro wie gewünscht klappt. Würde mich freuen. Leider kann ich es selb st nicht testen ...
    Die neuen Daten sollten aus der CSV Datei komplett übernommen werden, die alten Daten aus O-T werden wieder eingefügt!
    mfg Piet
  • Option Explicit
    
    Sub ImportCSV(Dateiname, ZielTabelle As String)
    Dim rFind As Range, FallNr, Arry
    Dim AC As Range, FinalRow As Long
    Dim WS As Worksheet, c, x As Long
    Dim AR As Worksheet, n, z As Long
    If Dateiname  False Then
    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
    With Worksheets("Aktuell stationär")
    Set AR = ThisWorkbook.Sheets("Archiv")
    'Nächste freie Zeile in Archiv suchen
    z = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'zuerst Prüfen ob Datensätze erloschen sind -> ins Archiv verschieben
    For x = 2 To FinalRow
    If .Cells(x, 6).End(xlDown).Row > FinalRow Then Exit For
    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)
    'Nicht gefunden Datensatz ins Archiv kopieren und löschen
    If rFind Is Nothing Then
    .Rows(x).Copy AR.Rows(z)     'ins Archiv kopieren
    .Rows(x).Delete shift:=xlUp  'Datensatz löschen
    z = z + 1:  x = x - 1:  c = c + 1
    End If
    Next x
    'vorhandene Datensätze mit CSV Daten überschreiben
    'Spalte O-T retten und alte Daten wieder eonfügen
    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 Not rFind Is Nothing Then
    Arry = .Cells(rFind.Row, "O").Resize(1, 6)  'alte Daten in Array retten
    WS.Rows(x).Copy .Rows(rFind.Row)    'neue Daten aus CSV Import übernehmen
    .Cells(rFind.Row, "O").Resize(1, 6) = Arry  'alte Daten wiederherstellen
    End If
    Next x
    'Nächste freie Zeile in Archiv suchen
    z = .Cells(Rows.Count, 6).End(xlUp).Row + 1
    'Prüfen ob neue Datensätze in CSV vorhanden sind
    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 Datensätze ins "Aktuell stationär" unten anhängen
    If rFind Is Nothing Then
    WS.Rows(x).Copy .Rows(z)     'ins "Aktuell stationär" kopieren
    z = z + 1:  n = n + 1        '** unten anhängen!!
    End If
    Next x
    End With
    End If
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("Aktuell stationŠr").Select
    Range("K1").Select
    MsgBox n & "  neue Datensätze" & vbLf & c & "  Datensätze gelöscht"
    End Sub
    

    
    Sub StartImportCSV()
    Dim fileToOpen As String
    fileToOpen = Application.GetOpenFilename()
    ImportCSV fileToOpen, "CSV Import"
    End Sub
    

  • Anzeige
    AW: offenstellen vergessen
    25.02.2022 12:39:09
    Piet
    Hallo
    offenstellen vergessen. Sollte alles klappen Thread bitte schliessen. Toi, toi toi ...
    mfg Piet
    AW: offenstellen vergessen
    25.02.2022 15:55:12
    setre
    Vielen Dank für die ganze Arbeit!
    Klappt leider noch nicht und ich finde leider den Fehler aktuell nicht.
    Das Makro kopiert die Daten in die Tabelle CSV, aber in Archiv und in Aktuell stationär tut sich gar nichts, unabhängig davon, ob schon Daten vorher drin waren oder nicht..
    Wenn du nochmal Gelegenheit hättest drüber zu schauen, würde ich mir sehr freuen!
    Vielen Dank!
    AW: VBA Probleme bei csv Import
    25.02.2022 20:12:40
    Piet
    Hallo
    auf ein neues! Ich bin es gewohnt und im Forum bekannt dafür das ich so lange hartnäckig an einem Thread bleibe bis meine Makros laufen!
    Neu eingefügt habe ich die vorübergehende Abschaltung der Formel Berechnungen. Ich habe auch einige Formeln in der Tabelle "Aktuell stationär" gesehen.
    Die werden beim Import der CSV Daten überschrieben, weil ich die ganze Zeile kopiere. Ist das korrekt, oder müssen die Formeln bestehen bleiben?
    Wenn ja, in welchen Spalten müssen sie bestehen bleiben?
    mfg Piet
  • Option Explicit
    
    Sub ImportCSV(Dateiname, ZielTabelle As String)
    Dim rFind As Range, FallNr, Arry
    Dim AC As Range, FinalRow As Long
    Dim WS As Worksheet, c, x As Long
    Dim AR As Worksheet, n, z As Long
    If Dateiname  False Then
    Application.Calculation = xlCalculationManual
    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
    With Worksheets("Aktuell stationär")
    Set AR = ThisWorkbook.Sheets("Archiv")
    'Nächste freie Zeile in Archiv suchen
    z = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
    FinalRow = .Cells(Rows.Count, 6).End(xlUp).Row
    'zuerst Prüfen ob Datensätze erloschen sind -> ins Archiv verschieben
    For x = 2 To FinalRow
    If .Cells(x, 6).End(xlDown).Row > FinalRow Then Exit For
    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)
    'Nicht gefunden Datensatz ins Archiv kopieren und löschen
    If rFind Is Nothing Then
    .Rows(x).Copy    'ins Archiv kopieren
    AR.Rows(z).PasteSpecial xlPasteValues
    .Rows(x).Delete shift:=xlUp  'Datensatz löschen
    z = z + 1:  x = x - 1:  c = c + 1
    End If
    Next x
    'vorhandene Datensätze mit CSV Daten überschreiben
    'Spalte O-T retten und alte Daten wieder eonfügen
    z = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    FinalRow = WS.Cells(Rows.Count, 6).End(xlUp).Row
    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 Not rFind Is Nothing Then
    Arry = .Cells(rFind.Row, "O").Resize(1, 6)  'alte Daten in Array retten
    WS.Rows(x).Copy    'iCSV Daten kopieren
    .Rows(rFind.Row).PasteSpecial xlPasteValues
    .Cells(rFind.Row, "O").Resize(1, 6) = Arry  'alte Daten wiederherstellen
    Else  'If rFind Is No thing
    WS.Rows(x).Copy   'neue Daten unten anhängen
    .Rows(z).PasteSpecial xlPasteValues
    z = z + 1:  n = n + 1
    End If
    Next x
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("Aktuell stationär").Select
    Range("K1").Select
    MsgBox n & "  neue Datensätze" & vbLf & c & "  Datensätze gelöscht"
    End Sub
    

    
    Sub StartImportCSV()
    Dim fileToOpen As String
    fileToOpen = Application.GetOpenFilename()
    ImportCSV fileToOpen, "CSV Import"
    End Sub
    

  • Anzeige
    AW: VBA Probleme bei csv Import
    25.02.2022 22:06:48
    setre
    Hi Piet,
    genau, die Formeln betreffen die Spalten K,L,M und N (ab Zeile 2). Ich habe die Formeln erstellt, weil ich die Datei später ausdrucken möchte und Platz sparen muss.
    So fasst z.B. Spalte K den Nachnamen, Vornahmen und Geb. der Person (Also Spalte A-C) in eine Zelle zusammen.
    Also so wie es bis jetzt gedacht ist sollen Spalten K-N bestehen bleiben (natürlich nur wenn die Person gleich bleibt, sonst neue Berechnung aus den ersten Spalten bzw. aus der CSV Tabelle mit den neuen Daten) und die Spalten O-T sind die Spalten, wo selbstständig etwas eingetragen werden muss, passend zur Person, da kann ich keine Formeln für benutzen, das sind die Spalten die dann übertragen werden müssten falls die Person in der Liste bestehen bleibt und quasi nur den Platz auf der Liste wechselt.
    Danke für die Nachfrage und liebe Grüße, und nochmals danke für die Mühe!
    Anzeige
    AW: VBA Probleme bei csv Import
    25.02.2022 22:07:10
    setre
    Hi Piet,
    genau, die Formeln betreffen die Spalten K,L,M und N (ab Zeile 2). Ich habe die Formeln erstellt, weil ich die Datei später ausdrucken möchte und Platz sparen muss.
    So fasst z.B. Spalte K den Nachnamen, Vornahmen und Geb. der Person (Also Spalte A-C) in eine Zelle zusammen.
    Also so wie es bis jetzt gedacht ist sollen Spalten K-N bestehen bleiben (natürlich nur wenn die Person gleich bleibt, sonst neue Berechnung aus den ersten Spalten bzw. aus der CSV Tabelle mit den neuen Daten) und die Spalten O-T sind die Spalten, wo selbstständig etwas eingetragen werden muss, passend zur Person, da kann ich keine Formeln für benutzen, das sind die Spalten die dann übertragen werden müssten falls die Person in der Liste bestehen bleibt und quasi nur den Platz auf der Liste wechselt.
    Danke für die Nachfrage und liebe Grüße, und nochmals danke für die Mühe!
    Anzeige
    AW: VBA Probleme bei csv Import
    26.02.2022 11:41:04
    Piet
    Hallo
    noch ein Gedicht! In eines Baumes Rinde, saß eine Made mit dem Kinde ...
    Den Kopiervorgang habe ich so verändert, das jetzt bei den existierenden Daten zwei getrennte Blöcke kopiert werden, statt die ganze Zeile. Spalte A-J und Y-AD
    Damit bleiben die Formeln in K-N und U-X erhalten, sie werden nicht überschrieben! Die alten Daten kopiere ich als ganze Zeile ins Archiv, als Text ohne Formeln!
    Neue Daten werden unten angehangen, und die Formeln in Spalte K-N und U-X aus Zeile 2 nach unten kopiert. Die Spalten O-T werden bei neuen Daten gelöscht!
    Ich hoffe das wir jetzt auf einem Stand sind wo das kopieren stimmig ist. Ich warte mal den Test ab ob alles fehlerfrei funktioniert. Würde mich freuen ....
    Herzliche Grüsse aus Ankara an die Heimat. Darf ich fragen wo das Programm im Einsatz ist, in welcher Stadt? Welche Klinik?
    mfg Piet
  • Option Explicit
    
    Sub ImportCSV(Dateiname, ZielTabelle As String)
    Dim rFind As Range, FallNr, Arry
    Dim AC As Range, FinalRow As Long
    Dim WS As Worksheet, c, x As Long
    Dim AR As Worksheet, n, z As Long
    If Dateiname  False Then
    Application.Calculation = xlCalculationManual
    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
    With Worksheets("Aktuell stationär")
    Set AR = ThisWorkbook.Sheets("Archiv")
    'Nächste freie Zeile in Archiv suchen
    z = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
    FinalRow = .Cells(Rows.Count, 6).End(xlUp).Row
    'zuerst Prüfen ob Datensätze erloschen sind -> ins Archiv verschieben
    For x = 2 To FinalRow
    If .Cells(x, 6).End(xlDown).Row > FinalRow Then Exit For
    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)
    'Nicht gefunden Datensatz ins Archiv kopieren und löschen
    If rFind Is Nothing Then
    .Rows(x).Copy    'ins Archiv kopieren
    AR.Rows(z).PasteSpecial xlPasteValues
    .Rows(x).Delete shift:=xlUp  'Datensatz löschen
    z = z + 1:  x = x - 1:  c = c + 1
    End If
    Next x
    'vorhandene Datensätze mit CSV Daten überschreiben
    'Spalte O-T retten und alte Daten wieder eonfügen
    FinalRow = WS.Cells(Rows.Count, 6).End(xlUp).Row
    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 Not rFind Is Nothing Then
    'alte Daten O-T in Array retten
    Arry = .Cells(rFind.Row, "O").Resize(1, 6)
    WS.Cells(x, 1).Resize(1, 10).Copy   'iCSV Daten A-J kopieren
    .Cells(rFind.Row, 1).PasteSpecial xlPasteValues
    WS.Cells(x, 25).Resize(1, 6).Copy   'iCSV Daten Y-AD kopieren
    .Cells(rFind.Row, 25).PasteSpecial xlPasteValues
    'alte Daten O-T wiederherstellen
    .Cells(rFind.Row, "O").Resize(1, 6) = Arry
    End If
    Next x
    'vorhandene Datensätze mit CSV Daten überschreiben
    'Spalte O-T retten und alte Daten wieder eonfügen
    z = .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
    'alte Daten O-T in Array retten
    WS.Rows(x).Copy   'iCSV Zeile kopieren
    .Rows(z).PasteSpecial xlPasteValues
    .Range("K2:N2").Copy .Cells(z, 11)   'Formeln K-N kopieren
    .Range("U2:X2").Copy .Cells(z, 21)   'Formeln U-X kopieren
    .Cells(z, 15).Resize(1, 6).ClearContents   'Spalte O-T löschen
    z = z + 1:  n = n + 1
    End If
    Next x
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.CutCopyMode = False
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Sheets("Aktuell stationär").Select
    Range("K1").Select
    MsgBox n & "  neue Datensätze" & vbLf & c & "  Datensätze gelöscht"
    End Sub
    

    
    Sub StartImportCSV()
    Dim fileToOpen As String
    fileToOpen = Application.GetOpenFilename()
    ImportCSV fileToOpen, "CSV Import"
    End Sub
    

  • Anzeige
    AW: VBA Probleme bei csv Import
    26.02.2022 13:58:16
    setre
    Hallo Piet,
    also das Kopieren klappt jetzt! Super, danke!!!
    Ich habe aktuell noch folgende Probleme mit dem Makro:
    Zuerst mal zum groben Verständnis:
    Am Ende möchte ich zwei Din A4 Seiten haben (Querformat) zum Ausdrucken mit 12 Personen pro Seite (mehr als 24 werden es wahrscheinlich nie sein insgesamt).
    Deswegen habe ich Für Seite 1 die Spalten K-T gewählt, und für Seite 2 U-AD mit jeweils 13 Zeilen (Zeile 1 bleiben die Überschriften).
    Die Spalten A-J werden ausgeblendet bleiben für den Endnutzer, damit es einfach und übersichtlich bleibt.
    Der Import findet ja über die Spalten A-J statt, dabei sollen die ersten zwölf Personen (also Zeile 2-13 von A-J) auf K-T (Zeile 2-13) aufgeteilt werden.
    Und die letzten zwölf Personen (also Zeile 14-25 aus A-J) zu U-AD (Zeile 2-13).
    (Wenn es weniger Personen gibt, dann soll nach Möglichkeit die Formatierung in K-AD immer gleich bleiben, nur dann mit leerem Inhalt)
    Also,
    gibt es eine also eine Möglichkeit die Spalten K-T und U-AD immer fest formatiert zu haben und nur den Inhalt der Zellen abzuändern, damit sich das finale Dokument zum Ausdrucken von der Formatierung her nicht ändert?
    (In den Spalten K-T sind K-N die Formeln, die Excel errechnen soll und O-T die Benutzereingaben; beide bleiben erhalten wenn die Person gleich bleibt, ansonsten O-T löschen und die Formeln beibehalten.
    In den Spalten U-AD sind U-X die Formeln und Y-AD die Benutzereingaben, gleiche Regeln wie bei K-T.)
    Da würde ich mich wahnsinnig freuen, wenn du dazu noch eine Idee hättest :)
    Ansonsten liebe Grüße in das bestimmt sonnige Ankara aus dem kalten Norddeutschland ;)
    Und um beim Gedicht zu bleiben:
    Sie ist Witwe, denn der Gatte,
    den sie hatte, fiel vom Blatte.
    Fängt ganz schön tragisch an
    Anzeige
    AW: VBA Probleme bei csv Import
    27.02.2022 16:46:29
    Piet
    Hallo
    auf Grund der letzten Info habe ich das Makro noch einmal überdacht und in einigen Teilen komplett neu aufgebaut. Ich nhoffe so passt es jetzt!
    Die Sache mit den Formeln und dem Zeilenversatz im Druckbere ch 2 hatte ich am Anfang nicht erkannt, das erforderte ein komplettes umdenken.
    Das neue Makro ist Universal, es ist für 4 Druckbereiche ausgelegt, und die können nebeneinader, untereinander oder gemischt sein. Spielt keine Rolle!
    Geprüft werden die Daten nach der Spalte F = Fall Nummer. Erloschen Daten nkommen wie gehabt ins Archiv, neue werden unten angehangen, wie bisher.
    Ich kopiere aber nicht mehr die ganze Zeile, um alle Formeln zu erhalten, sondern nur die Spalten A-J aus der CSV Datei.
    Vor dem bearbeiten rette ich alle Daten aus vier Druckbereichen in das Blatt CSV, ab Spalte BA. Dort kannst du alle vorhandenen Patienten Daten sehen. (O-T Daten)
    Zum zurückladen kann ich nicht die Fall Nummer zum suchen nehmen, denn im Druckbereich ist KEINE Fall Nummer vorhanden! Deshalb dieser neue Weg.
    Zum zurückladen suche ich im Druckbereich nach dem Kombi Namen, aus Name, Vorname und Geb.Datum. Damit kann ich alle Daten wieder zuordnen!
    Beim löschen verrutschen die Daten ja durch die Formel, können sich auch zwischen den Druckbereichen verschieben. Das war mein Programmier Problem.
    Ich denke die neue Variante sollte dieses Problem jetzt endlich lösen. Ich bin auf deine Rückmeldung gespannt ....
    Weil vieles neu ist bitte zuerst wieder in einer Kopiedatei testen. Ich kann nicvht garantieren das sofort alles klappt.
    mfg Piet
  • Option Explicit
    
    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
    '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
    zCS = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    zAr = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'LastZell in "Aktuell stationär" suchen
    FinalRow = .Cells(Rows.Count, 1).End(xlUp).Row
    'zuerst 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
    'dann neue CSV Datensätze in "Aktuell stationär" unten anhängen
    FinalRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    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
    '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
    '**  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
    

    
    Sub StartImportCSV()
    Dim fileToOpen As String
    fileToOpen = Application.GetOpenFilename()
    ImportCSV fileToOpen, "CSV Import"
    End Sub
    

  • Anzeige
    AW: offenstellen vergessen
    27.02.2022 16:48:45
    Piet
    ...
    AW: offenstellen vergessen
    27.02.2022 17:25:33
    setre
    Wahnsinn, vielen Dank für die ganze Mühe!
    Also das kopieren klappt jetzt super, und die Formatierungen werden beibehalten :)
    Ein Problem habe ich noch gefunden:
    Wenn die neue CSV Datei mehr Zeilen enthält (also mehr Personen) als die vorherige Version, dann werden die Spalten O-T wie gewünscht geleert.
    Aber wenn die neue CSV Datei weniger Zellen enthält als die vorherige bzw als das was aktuell in Spalten A-J ist, dann werden die Spalten O-T nicht geleert.
    Woran könnte das liegen?
    AW: offenstellen vergessen
    27.02.2022 17:33:02
    setre
    Nachtrag:
    Wenn die neue CSV Datei kürzer ist als die alte, dann entstehen im Druckbereich (Spalten K-T) leere Zeilen wenn es Übereinstimmungen gibt.
    Gibt es da auch noch eine Möglichkeit, das zu korrigieren oder hilft da die Sortieren und Filtern Funktion in Excel?
    Liebe Grüße!
    AW: VBA Probleme bei csv Import
    28.02.2022 09:46:00
    Piet
    Hallo
    das sollte normalerweise nicht passieren, denn das Makro kopiert zuerst alle Patientendaten aus den Druckbereichen in die CSV Tabelle, und lädt nur die Daten von den Patienten zurück, die noch auf der CSV Liste stehen. Die anderen sollten ins Archiv verschoben sein. Kannst du das bitte noch mal in meiner Datei prüfen.
    Ich sende dir meine Testdatei, mit der ich das Programm entwickelt habe. Im Blatt "Aktuell" gibt es einen Button der ein Test Makro startet.Es macht alle Funktionen OHNE die CSV Datei zu laden, die hatte ich ja nicht. Dafür hatte ich im CSV Blatt Fantasiedaten reingeschrieben und damit das Makro getestet. Schau bitte was passiert wenn du in den Spalten A-J Daten löschst (ohne Leerzeilen) und dann das Makro startest. Ob das verschieben ins Archiv einwandfrei funktioniert.
    Ich denke ich habe die Formeln lückenlos übernommen, aber mit weniger als 12 Zeilen. Sonst könnten Lücken entstehen. Die Formel Reihenfolge muss natürlich stimmen!
    https://www.herber.de/bbs/user/151445.xlsm
    mfg Piet
    AW: VBA Probleme bei csv Import
    28.02.2022 09:58:26
    Piet
    Nchtrag
    bei einer früheren Version hatte ich beim verschieben ins Archiv die aktuelle Zeile gelöscht. Nachteil, dann stimmt die Formel nicht mehr, hat einen "Bezugs" Fehler!
    Das habe ich inzwischen geändert. Stimmen in deinem Original noch alle Formeln, oder gab es da vielleicht Fehler durch mein Makro?
    mfg Piet
    AW: VBA Probleme bei csv Import
    28.02.2022 12:39:34
    setre
    Hallo piet,
    also bei deiner Version klappt das Verschieben ins Archiv,
    und in der Aktuell Tabelle ändern sich auch die Namen korrekt wenn ich in CSV etwas lösche.
    Was sowohl in deiner als auch in meiner Datei passiert ist, dass die Eingaben aus O-T in der gleichen Zelle bleiben, wenn ich also jemanden lösche, dann rutschen diese Werte quasi nicht nach sondern werden dann einer neuen Person zugeordnet, weil sich die Verteilung in K-M ändert.
    Was mir auch noch in meiner Datei aufgefallen ist, dass wenn ich z.b. eine neue CSV Datei auswähle die nur noch bspw. 1 Person enthält, dann löscht das Makro zwar alle nicht mehr vorhandenen aus A-J aber fügt dann die neue Person in die unterste erste leere Zeile ein, und nicht in Zeile 2, wo sie ja eigentlich stehen müsste.
    AW: VBA Probleme bei csv Import
    28.02.2022 20:13:10
    Piet
    Hallo
    ich glaube ich habe einen ganzn dummen Fehler im Programm,der sich aber leicht beheben lässt. Bitte das Makro tauschen!
    Beim Start des Makro setze ich die Formelberechnung per VBA auf Manuell, und zum Schluß wieder auf Automatik!
    Nach dem löschen und verschieben ins Archiv MÜSSEN die Formeln aber neu berechnet werden, sonst klappt das zurückladen der O-T Daten nicht!!
    Bei der Neuberechnung verschieben sich ja die Personen. Bitte jetzt mal testen ob die zurückgeladenen Daten mit den Personen übereinstimmen.
    Kann es auch vorkommen das es nur eine Person gibt? Das habe ich bisher nicht berücksichtigt, muss das noch mal prüfen.
    mfg Piet
  • 
    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
    '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
    zCS = .Cells(Rows.Count, 1).End(xlUp).Row + 1
    zAr = AR.Cells(Rows.Count, 1).End(xlUp).Row + 1
    'LastZell in "Aktuell stationär" suchen
    FinalRow = .Cells(Rows.Count, 1).End(xlUp).Row
    'zuerst 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
    'dann neue CSV Datensätze in "Aktuell stationär" unten anhängen
    FinalRow = WS.Cells(Rows.Count, 1).End(xlUp).Row
    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
    '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
    '**  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
    

  • AW: VBA Probleme bei csv Import
    28.02.2022 21:50:07
    setre
    Super, danke, probiere es aus.
    Ja mit einer Person in der Liste kann vorkommen.
    Meistens sind aber 1-15 Personen in der Liste.
    AW: VBA Probleme bei csv Import
    28.02.2022 22:33:22
    setre
    Also die Neuberechnung klappt, die Werte aus O-T werden jetzt wieder richtig zugeordnet, super!
    Leider ist mir noch etwas aufgefallen.
    Beispiel:
    Ich importiere eine CSV Datei mit 15 Personen, alles wird übertragen.
    Dann importiere ich eine CSV Datei mit 12 Personen (habe z.B. 3 Leute in der Mitte der Liste gelöscht). Dann wird die letzte Zeile (Person 12) so oft nachbesetzt, bis wieder die letzte Zeile der alten CSV Datei voll ist (also in dem Beispiel hier 3 Mal Zeile 14,15,16 sind dann alles die gleiche Person 12).

    307 Forumthreads zu ähnlichen Themen

    Anzeige
    Anzeige
    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige

    Beliebteste Forumthreads (12 Monate)

    Anzeige
    Anzeige
    Anzeige