CSV auftrennen und kopieren
02.05.2017 15:52:14
Christian
Makro 1. Öffnen der CSV Dateien eines Ordners und kopieren in die Arbeitsmappe, sowie Auftrennen in die entsprechenden Spalten. Ich möchte hier (sofern es nicht einfacher geht) alle nachfolgenden Makros einbinden.
Sub CSV_Import2()
Dim strPfad As String
Dim lngLastRow As Long
Dim myFileSystemObject, myFiles
'https://www.computerbase.de/forum/showthread.php?t=795101
'https://www.herber.de/forum/archiv/1148to1152/1148032_CSVDateien_mit_VBA_einlesen.html
' Pfad hier anpassen
strPfad = "D:\Daten\Test\Rohdatenbank"
Set myFileSystemObject = CreateObject("Scripting.FileSystemObject")
For Each myFiles In myFileSystemObject.GetFolder(strPfad).Files
If InStr(UCase(myFiles), ".CSV") Then
lngLastRow = ActiveSheet.Cells(65535, 2).End(xlUp).Row
ActiveSheet.Cells(lngLastRow + 1, 1) = Split(myFiles.Name, ".")(0) 'Schreiben des _
Pfades und Dateinamen in A2
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & myFiles, Destination:=Range(Cells(lngLastRow + 2, 1), Cells(lngLastRow + _
_
2, 1))) ' Ablage ab A3
.Name = myFiles
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = True
.TextFileSemicolonDelimiter = False 'Strichpunkt als Spalten-Trennzeichen
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileDecimalSeparator = "." ' Punkt als Dezimaltrennzeichen (Standard Komma) _
.TextFileThousandsSeparator = "," ' Komma für Tausendergruppierung (Standard _
Punkt)
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
End If
Next myFiles
End Sub
- es sollen nur die Daten der ersten/obersten/... hauptsache nur einer Datei eingefügt werden
- wenn die Daten einer Datei abgearbeitet wurden soll die CSV am Ende gelöscht werden bevor die nächste aufgerufen wird (damit er immer mit der ersten/obersten neu anfangen kann)
-Schleife bilden im Makro 1, dass Makro 1-6 solange erneut durchlaufen werden, bis keine _ Dateien mehr in dem Ordner sind.
strPfad = "D:\Daten\Test\Rohdatenbank"
Makro 2. Pfade, Dateinamen, letzte Zeilen suchen
I1 = Pfadname CSV's || J1 = Pfadname der Zieldatein || K1 = Dateiname Ziel || L1 = Tabellenblattname Ziel || N1 = Letzte Zeile Arbeitsmappe (Quelle)
(werden automatisch nach dem Import gebildet)
Letzte Zeile der Datenbank suchen und in M1 schreiben
Option Explicit
Sub Last_Row_Copy()
Dim p, f, s, r As String
Dim gPfad, gDatei, gMappe As String
r = "A1"
gPfad = Cells(1, 10).Value
gDatei = Cells(1, 11).Value
gMappe = Cells(1, 12).Value
p = gPfad
f = gDatei
s = gMappe
Worksheets("#Konverter").Range("M1") = GetValue(p, f, s, r)
End Sub
Private Function GetValue(Path, file, sheet, ref)
' Retrieves a value from a closed workbook
Dim arg As String
' Make sure the file exists
If Right(Path, 1) "\" Then Path = Path & "\"
If Dir(Path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & Path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Option Explicit
Sub Dat_Time_Copy()
Dim p, f, s, r As String
Dim gPfad, gDatei, gMappe As String
r = "A1"
'Zellen mit Pfad, Dateinamen, Mappe
gPfad = Cells(1, 10).Value
gDatei = Cells(1, 11).Value
gMappe = Cells(1, 12).Value
'Übergabe in Variable
p = gPfad
f = gDatei
s = gMappe
Worksheets("#Konverter").Range(Cells(1, 15), Cells(1, 16)) = GetValue(p, f, s, r)
End Sub
Private Function GetValue(Path, file, sheet, ref)
' Retrieves a value from a closed workbook
Dim arg As String
Dim lzeile As Long
'Letzte Zeile DB
lzeile = Cells(1, 13).Value
' Make sure the file exists
If Right(Path, 1) "\" Then Path = Path & "\"
If Dir(Path & file) = "" Then
GetValue = "File Not Found"
Exit Function
End If
' Create the argument
arg = "'" & Path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range(Cells(lzeile - 1, 1), Cells(lzeile - 1, 1)).Address(, , xlR1C1)
' Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
Makro 3.
-Datum (O1) & Uhrzeit (P1) vergleichen mit Spalte A (Datum) und Spalte B (Uhrzeiten)
-Zu kopierender Bereich
Range(Cells(Zeile bei der die Beding. erfüllt ist, 1), Cells(Wert aus N1, 32))
-Einfügen in (im geschlossenen oder unsichtbaren Zustand)
Zielpfad: gPfad = Cells(1, 10).Value
Zieldatei: gDatei = Cells(1, 11).Value
Zielmappe: gMappe = Cells(1, 12).Value
ab Zielzelle: Wert aus M1
-Zieldatei speichern & schließen
Makro 4.
-aktuelles Tabellenblatt säubern
Range(Cells(2, 1), Cells(Wert aus N1, 32))
Makro 5.
-die abgearbeitete CSV Datei löschen, falls nötig / möglich
CSV-Pfad: steht in I1
Dateiname: steht in A2 ohne .csv
Makro 6.
- Das Makro sucht die nächste csv, importiert die Daten mit Makro 1 und bearbeitet die Schrittkette 2,3,4,5 erneut.
Für mich ist das alles noch Neuland, daher bitte nicht so streng sein. Ich bin über jede Hilfe super dankbar, da ich nichtmal in der Lage wäre aus Makro 1 eine funktionierende Schleife zu bauen. Wenn irgendwelche Fragen sind versuche ich diese bestmöglich zu beantworten.