AW: Mehrere csv Dateien importieren
09.03.2025 00:58:52
Anja_089
Hallo Udo, Hallo Oberschlumpf,
ich benötige eine code den ich selber anpassen kann, damit ich ihn auf die jeweiligen Gegebenheiten anpassen kann.
Quelldatei
Bei csv.Dateien gibt es oft eine Überschrift, die ich nicht importieren will. Sprich der Import der Daten soll z.B. erst ab Zeile 2 oder 3 stattfinden.
Ich will mehrere Dateien gleichzeitig importieren, die ich selber in einem Ordner auswählen kann.
Die Dateien sind gleich aufgebaut, haben jedoch unterschiedliche Zeilenlängen. Also mal mehr oder weniger Daten. Daher muss in jeder importierenden Datei die ermittelt werden, wo die jetzt beschriebenen Zeile vorhanden ist.
Ich will bestimmen können welche Spalten ich importieren kann, weil ich einen Teil der Daten nicht benötige. Spalten A-K.
Sie sollen bei Import untereinander eingefügt werden. Die Daten sind immer im ersten Tabellenblatt vorhanden, haben aber unterschiedlichen Namen in dem Register. Somit muss das Tabellenblatt mit zb. Tabelle 1 (Worksheet (1))und nicht mit dem Namen angesprochen werden.
Zieldatei
Ich habe 12 Tabellenblätter in dem sich jeweils ein Button befindet. Wenn man dauf klickt, sollen die Daten an einer Stelle eingefügt werden, die ich selber bestimmen kann. In den Tabellenblättern sind Überschriften vorhanden, also muss der Import erst ab Zeile A8 erfolgen. Neben den importierten Daten stehen Formeln, die nicht überschrieben werden sollen. Also Daten nur von Spalte A-K einfügen. Ich möchte selber entscheiden in welches Tabellenblatt die Daten importiert werden sollen.
Es ist wahrscheinlich einfacher, die Daten in ein neutrales Tabellenblatt zu importieren und von dort aus in das jeweilige Tabellenblatt zu übertragen. So kann ich es per Werte einfügen übertragen, womit dann auch die Formatierungen nicht überschrieben werden. Egal von welchem Tabellenblatt ich den Button aufrufe.
Codes
Anbei ein Codes für den Import von Dateien aus einem Excelsheet. So etwas in der Art brauche ich nur für csv Dateien. Da funktioniert er nämlich nicht, weil die Daten nicht getrennt werden. Mit diesem Code arbeite ich schon viele Jahre. Ich importiere auch hier die Daten erst einmal in ein neutrales Tabellenblatt und übertrage von dort aus die Daten in die gewünschten Tabellenblätter.
Private Sub cmdImportB_Click()
On Error Resume Next
ActiveWindow.ScrollColumn = 1
ActiveSheet.ShowAllData
ActiveSheet.Range("A16:AN30000").EntireRow.Hidden = False
'ActiveSheet.Range("A16:S30000").FormatConditions.Delete
On Error GoTo errExit
Dim wbQuelle As Workbook, Quelle As Worksheet, Ziel As Worksheet
Dim Datei As Variant, varDateien
Dim Zeile_Z As Long, Zeile_S1 As Long, Zeile_S2 As Long
Dim rngZelle As Range
' ++++++++++++++++++++
Dim lngAnzahl As Long
Dim lngLastQ As Long
'Worksheets("Einträge").Visible = True
Sheets("Einträge").Activate
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
varDateien = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", _
Title:="Bitte zu importieren Datei(en) auswählen", MultiSelect:=True)
' ++++++++++++++++++++
' For lngAnzahl = LBound(varDateien) To UBound(varDateien)
'Abbrechen falls keine Datei ausgewählt
If Not IsArray(varDateien) Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
Application.DisplayAlerts = False
End With
' Zieldatei
Set Ziel = ThisWorkbook.Worksheets("Test")
With Ziel
'Startzeile setzen
Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
Zeile_Z = 14
Else
Zeile_Z = rngZelle.Row
End If
If Zeile_Z 14 Then
Zeile_Z = 14
Else
Zeile_Z = Zeile_Z + 1
End If
End With
'Ausgewählte Datei abarbeiten
For Each Datei In varDateien
' MsgBox "Ausgewählte Datei: " & Datei, , ""
Set wbQuelle = Workbooks.Open(Filename:=Datei, ReadOnly:=True)
' Quelldatei
Set Quelle = wbQuelle.Worksheets("Einträge")
With Quelle
Zeile_S1 = 14
'Letzte Zeile in Quelle
Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
'keine Daten
GoTo NextDatei
Else
Zeile_S2 = rngZelle.Row
End If
If Zeile_S2 >= Zeile_S1 Then
'kopieren und einfügen
' ' .Range(.Rows(Zeile_S1), .Rows(Zeile_S2)).Copy Ziel.Cells(Zeile_Z, 1)
' ############# Bisher verwendeter Code
' .Range(.Cells(Zeile_S1, 1), .Cells(Zeile_S2, 40)).Copy Ziel.Cells(Zeile_Z, 1)
' ############# Mein neuer Code, mit der Fehlermeldung
.Range(.Cells(Zeile_S1, 1), .Cells(Zeile_S2, 40)).Copy
Ziel.Cells(Zeile_Z, 1).PasteSpecial xlPasteValues
'nächste Einfügezeile
Zeile_Z = Zeile_Z + Zeile_S2 - Zeile_S1 + 1
End If
End With
NextDatei:
wbQuelle.Close savechanges:=False
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Next Datei
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
MsgBox "FehlerNr.: " & .Number & vbNewLine & vbNewLine _
& "Beschreibung: " & .Description, _
vbCritical, "Fehler"
End Select
End With
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Set Ziel = Nothing
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
Application.DisplayAlerts = True
End With
'Zeilen löschen
'Letzten Stand Aktualisierung eintragen
'Range("L5").Select
' ActiveCell.FormulaR1C1 = "=NOW()"
' Range("L5").Select
' Selection.Copy
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
' ++++++++++++++++++++
MsgBox "Es werden " & UBound(varDateien) & " Dateien eingefügt.", 64
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Private Sub cmdImportB_Click()
On Error Resume Next
ActiveWindow.ScrollColumn = 1
ActiveSheet.ShowAllData
ActiveSheet.Range("A16:AN30000").EntireRow.Hidden = False
'ActiveSheet.Range("A16:S30000").FormatConditions.Delete
On Error GoTo errExit
Dim wbQuelle As Workbook, Quelle As Worksheet, Ziel As Worksheet
Dim Datei As Variant, varDateien
Dim Zeile_Z As Long, Zeile_S1 As Long, Zeile_S2 As Long
Dim rngZelle As Range
' ++++++++++++++++++++
Dim lngAnzahl As Long
Dim lngLastQ As Long
'Worksheets("Einträge").Visible = True
Sheets("Einträge").Activate
On Error GoTo Fehler
'Dialog "Datei öffnen" anzeigen
varDateien = Application.GetOpenFilename("Excel Dateien (*.xls; *.xlsx; *.xlsm)," & _
"*.xls; *.xlsx; *.xlsm", _
Title:="Bitte zu importieren Datei(en) auswählen", MultiSelect:=True)
' ++++++++++++++++++++
' For lngAnzahl = LBound(varDateien) To UBound(varDateien)
'Abbrechen falls keine Datei ausgewählt
If Not IsArray(varDateien) Then
MsgBox "keine Datei ausgewählt", , "Abbruch"
Exit Sub
End If
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
Application.DisplayAlerts = False
End With
' Zieldatei
Set Ziel = ThisWorkbook.Worksheets("Test")
With Ziel
'Startzeile setzen
Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
Zeile_Z = 14
Else
Zeile_Z = rngZelle.Row
End If
If Zeile_Z 14 Then
Zeile_Z = 14
Else
Zeile_Z = Zeile_Z + 1
End If
End With
'Ausgewählte Datei abarbeiten
For Each Datei In varDateien
' MsgBox "Ausgewählte Datei: " & Datei, , ""
Set wbQuelle = Workbooks.Open(Filename:=Datei, ReadOnly:=True)
' Quelldatei
Set Quelle = wbQuelle.Worksheets("Einträge")
With Quelle
Zeile_S1 = 14
'Letzte Zeile in Quelle
Set rngZelle = .Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngZelle Is Nothing Then
'keine Daten
GoTo NextDatei
Else
Zeile_S2 = rngZelle.Row
End If
If Zeile_S2 >= Zeile_S1 Then
'kopieren und einfügen
' ' .Range(.Rows(Zeile_S1), .Rows(Zeile_S2)).Copy Ziel.Cells(Zeile_Z, 1)
' ############# Bisher verwendeter Code
' .Range(.Cells(Zeile_S1, 1), .Cells(Zeile_S2, 40)).Copy Ziel.Cells(Zeile_Z, 1)
' ############# Mein neuer Code, mit der Fehlermeldung
.Range(.Cells(Zeile_S1, 1), .Cells(Zeile_S2, 40)).Copy
Ziel.Cells(Zeile_Z, 1).PasteSpecial xlPasteValues
'nächste Einfügezeile
Zeile_Z = Zeile_Z + Zeile_S2 - Zeile_S1 + 1
End If
End With
NextDatei:
wbQuelle.Close savechanges:=False
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Next Datei
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
If Not wbQuelle Is Nothing Then wbQuelle.Close savechanges:=False
MsgBox "FehlerNr.: " & .Number & vbNewLine & vbNewLine _
& "Beschreibung: " & .Description, _
vbCritical, "Fehler"
End Select
End With
errExit:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
End With
'Speicher freigeben
Set Quelle = Nothing
Set wbQuelle = Nothing
Set Ziel = Nothing
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
Application.DisplayAlerts = True
End With
'Zeilen löschen
'Letzten Stand Aktualisierung eintragen
'Range("L5").Select
' ActiveCell.FormulaR1C1 = "=NOW()"
' Range("L5").Select
' Selection.Copy
' Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
' :=False, Transpose:=False
' ++++++++++++++++++++
MsgBox "Es werden " & UBound(varDateien) & " Dateien eingefügt.", 64
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub