Top-Themen

AppleEntwicklungHardwareInternetLinuxMicrosoftMultimediaNetzwerkeOff TopicSicherheitSonstige SystemeVirtualisierungWeiterbildungZusammenarbeit

Aktuelle Themen

Administrator.de FeedbackApache ServerAppleAssemblerAudioAusbildungAuslandBackupBasicBatch & ShellBenchmarksBibliotheken & ToolkitsBlogsCloud-DiensteClusterCMSCPU, RAM, MainboardsCSSC und C++DatenbankenDatenschutzDebianDigitiales FernsehenDNSDrucker und ScannerDSL, VDSLE-BooksE-BusinessE-MailEntwicklungErkennung und -AbwehrExchange ServerFestplatten, SSD, RaidFirewallFlatratesGoogle AndroidGrafikGrafikkarten & MonitoreGroupwareHardwareHosting & HousingHTMLHumor (lol)Hyper-VIconsIDE & EditorenInformationsdiensteInstallationInstant MessagingInternetInternet DomäneniOSISDN & AnaloganschlüsseiTunesJavaJavaScriptKiXtartKVMLAN, WAN, WirelessLinuxLinux DesktopLinux NetzwerkLinux ToolsLinux UserverwaltungLizenzierungMac OS XMicrosoftMicrosoft OfficeMikroTik RouterOSMonitoringMultimediaMultimedia & ZubehörNetzwerkeNetzwerkgrundlagenNetzwerkmanagementNetzwerkprotokolleNotebook & ZubehörNovell NetwareOff TopicOpenOffice, LibreOfficeOutlook & MailPapierkorbPascal und DelphiPeripheriegerätePerlPHPPythonRechtliche FragenRedHat, CentOS, FedoraRouter & RoutingSambaSAN, NAS, DASSchriftartenSchulung & TrainingSEOServerServer-HardwareSicherheitSicherheits-ToolsSicherheitsgrundlagenSolarisSonstige SystemeSoziale NetzwerkeSpeicherkartenStudentenjobs & PraktikumSuche ProjektpartnerSuseSwitche und HubsTipps & TricksTK-Netze & GeräteUbuntuUMTS, EDGE & GPRSUtilitiesVB for ApplicationsVerschlüsselung & ZertifikateVideo & StreamingViren und TrojanerVirtualisierungVisual StudioVmwareVoice over IPWebbrowserWebentwicklungWeiterbildungWindows 7Windows 8Windows 10Windows InstallationWindows MobileWindows NetzwerkWindows ServerWindows SystemdateienWindows ToolsWindows UpdateWindows UserverwaltungWindows VistaWindows XPXenserverXMLZusammenarbeit
GELÖST

Alle CSV-Dateien in einem Ordner mit einem VBA Makro einlesen

Frage Entwicklung VB for Applications

Mitglied: 113139

113139 (Level 1)

27.08.2013 um 09:31 Uhr, 25838 Aufrufe, 37 Kommentare, 3 Danke

Hallo liebe Community,

Ich bin neu im Forum und hoffe ihr könnt mir vielleicht helfen
Ich habe einen Ordner, in dem sich mehrere CSV Dateien befinden.
Diese möchte ich per Makro in Ecxel importieren.
Und zwar so, dass sie bei der ausgabe gleich das richtige Zeilen- und Spaltenformat haben.
Der Ordner wird ab und zu aktualisiert, d.h. dieses Makro sollte dann bei Ausführung die jeweils aktuellen Dateien im Ordner in Ecxel importieren und veraltete Dateien, die evtl noch vorhanden sind ersetzen.
Ich habe bereits ein Makro im Internet gefunden, welches alle Dateien auf einmal einliest, allerdings war das Tabellen Layout meiner CSV Dateien dabei verschwunden.
Sie wurden fortlaufend in eine Zeile geschrieben und dieses Problem würde ich sehr gerne umgehen.
Ich würde mich sehr über eure Hilfe freuen

LG Lemon
37 Antworten
Mitglied: colinardo
27.08.2013, aktualisiert um 13:40 Uhr
Hallo Lemon,
das könntest du z.B. so realisieren:
Das Makro öffnet jede CSV-Datei in einem Ordner, führt die Spaltenerkennung durch und kopiert den Inhalt in ein Worksheet mit dem Namen der CSV-Datei in deine Excel-Datei. Die Optionen für die Texterkennung der CSV-Datei musst du an das Format deiner CSV-Dateien in Zeile 25 des Codes anpassen. Im Beispiel werden Semikolons zur Spaltentrennung verwendet. Den Pfad zu den CSV-Dateien musst du noch in Zeile 2 des Codes anpassen.
01.
Sub ImportiereCSVDateien() 
02.
    Const CSVPFAD = "E:\csv-dateien" 
03.
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet 
04.
    Set fso = CreateObject("Scripting.Filesystemobject") 
05.
    Set wbTarget = ActiveWorkbook 
06.
    Application.DisplayAlerts = False 
07.
    'Lösche alle Worksheets bevor wir alle neu anlegen 
08.
    If wbTarget.Worksheets.Count > 1 Then 
09.
        For i = 1 To wbTarget.Worksheets.Count - 1 
10.
            wbTarget.Worksheets(i).Delete 
11.
        Next 
12.
    End If 
13.
    For Each f In fso.GetFolder(CSVPFAD).Files 
14.
        If LCase(Right(f.Name, 3)) = "csv" Then 
15.
            Workbooks.OpenText Filename:=f.Path 
16.
            Set wbSource = ActiveWorkbook 
17.
            On Error Resume Next 
18.
            Set ws = wbTarget.Worksheets(f.Name) 
19.
            If Err <> 0 Then 
20.
                Set ws = wbTarget.Worksheets.Add 
21.
                ws.Name = f.Name 
22.
                ws.Range("A:ZZ").Clear 
23.
            End If 
24.
         
25.
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True 
26.
            wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1") 
27.
            wbSource.Close False 
28.
        End If 
29.
    Next 
30.
    Application.DisplayAlerts = True 
31.
    Set fso = Nothing 
32.
End Sub
Grüße Uwe
Bitte warten ..
Mitglied: 113139
27.08.2013 um 14:07 Uhr
Hallo Uwe,

Vielen Dank für deine schnelle Antwort.
Ich neu was das programmieren und das arbeiten mit Scripts angeht und habe deswegen immernoh ein paar Probleme Fehler in meinen Dateien und Scripts zu erkennen. Ich habe dein Makro gleich ausprobiert und VBA markiert mir gleich die erste Zeile gelb "Sub ImportiereCSVDateien()" und verweist mich auf "Set fso" in der 4. Zeile. Den Pfad der Dateien habe ich schon eingetragen. Weißt du vllt woran das leigen könnte?

LG Lemon
Bitte warten ..
Mitglied: colinardo
27.08.2013 um 14:17 Uhr
Ich hoffe du hast das Script von dieser Seite nicht inklusive der Zeilennummern in dein VBA Projekt kopiert !! Dazu gibt es den Link "Quelltext" oben rechts des Codes.
Bitte warten ..
Mitglied: 113139
29.08.2013 um 08:36 Uhr
Ne Ne^^ nur den reinen Text.
Bitte warten ..
Mitglied: colinardo
29.08.2013 um 08:41 Uhr
Hast du zufällig Oben im Codefenster Option Explicit stehen ?, dann lösch es mal raus.
Welche Fehlermeldung bringt dein Excel denn dazu?
Habe das Script hier erfolgreich getestet...

Grüße Uwe
Bitte warten ..
Mitglied: 113139
29.08.2013 um 11:01 Uhr
Ah super jetzt klappts
Vielen Dank!!!

Ich habe zum Test 3 Dateien im Ordner gehabt.
Er hat mir für jede ein neues Tabellenblatt angelegt.
Kannst du mir vllt noch verraten, wie er zusätzlich noch eins erstellt, in dem alle aufeinmal aufgelistet werden?
Wäre echt klasse

Aber trotzdem schonmal vielen Dank für das tolle Makro
Das macht die ganze Sache erheblich leichter

Gruß Lemon
Bitte warten ..
Mitglied: colinardo
29.08.2013 um 11:49 Uhr
Zitat von 113139:
Kannst du mir vllt noch verraten, wie er zusätzlich noch eins erstellt, in dem alle aufeinmal aufgelistet werden?
Wäre echt klasse
01.
Sub ImportiereCSVDateien() 
02.
    Const CSVPFAD = "E:\csv-dateien" 
03.
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet 
04.
    Set fso = CreateObject("Scripting.Filesystemobject") 
05.
    Set wbTarget = ActiveWorkbook 
06.
    Application.DisplayAlerts = False 
07.
    'Lösche alle Worksheets bevor wir alle neu anlegen 
08.
    While wbTarget.Worksheets.Count > 1 
09.
            wbTarget.Worksheets(1).Delete 
10.
    Wend 
11.
    wbTarget.Worksheets(1).Name = "Zusammenfassung" 
12.
    wbTarget.Worksheets(1).Range("A:ZZ").Clear 
13.
    For Each f In fso.GetFolder(CSVPFAD).Files 
14.
        If LCase(Right(f.Name, 3)) = "csv" Then 
15.
            Workbooks.OpenText Filename:=f.Path 
16.
            Set wbSource = ActiveWorkbook 
17.
            On Error Resume Next 
18.
            Set ws = wbTarget.Worksheets(f.Name) 
19.
            If Err <> 0 Then 
20.
                Set ws = wbTarget.Worksheets.Add 
21.
                ws.Name = f.Name 
22.
                ws.Range("A:ZZ").Clear 
23.
            End If 
24.
         
25.
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True 
26.
            wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1") 
27.
            wbSource.Close False 
28.
        End If 
29.
    Next 
30.
    Set ts = wbTarget.Worksheets("Zusammenfassung") 
31.
    Dim curCell As Range 
32.
    Set curCell = ts.Range("A1") 
33.
    For i = 1 To wbTarget.Worksheets.Count - 1 
34.
        maxRow = wbTarget.Worksheets(i).Range("A1").End(xlDown).Row 
35.
        maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column 
36.
        wbTarget.Worksheets(i).Range(wbTarget.Worksheets(i).Cells(1, 1), wbTarget.Worksheets(i).Cells(maxRow, maxCol)).Copy Destination:=curCell 
37.
        Set curCell = curCell.End(xlDown).Offset(2, 0) 
38.
    Next 
39.
    Application.DisplayAlerts = True 
40.
    Set fso = Nothing 
41.
End Sub
Viel Spaß
Grüße Uwe
Bitte warten ..
Mitglied: 113139
30.08.2013 um 14:34 Uhr
Hallo Uwe,

Alles klappt total super einwandfrei!
Vielen Vielen Dank

Grüße Lemon
Bitte warten ..
Mitglied: colinardo
30.08.2013 um 15:04 Uhr
gern geschehen!
Bitte den Beitrag noch als gelöst markieren.

Grüße Uwe
Bitte warten ..
Mitglied: sommer2013
11.03.2014, aktualisiert um 10:11 Uhr
Hallo zusammen,

ich bin auch neu hier und bin begeistert, dass ich das gefunden habe, was ich schon lange suche.

Der Import der CSV-Dateien aus einem Ordner in eine Excel Datei klappt sehr gut. Allerdings habe ich noch ein kleines Problem:

aus ursprünglich:
"
Trendlogs

Timestamp Trend__Archive1
30.01.2014 00:07 190,387
30.01.2014 00:22 190,387
30.01.2014 00:37 190,388
30.01.2014 00:52 190,389
30.01.2014 01:07 190,390
.
.
.
.
....

"

wird folgendes importiert:
"
Trendlogs

Timestamp Trend__Archive1
30.01.2014 00:07:36 190
30.01.2014 00:22:35 190
30.01.2014 00:37:34 190
30.01.2014 00:52:34 190
30.01.2014 01:07:33 190
.
.
.
.
...."
Zeilen >10000


Dabei wird die Nachkommastelle des Messwertes abgeschnitten (190,xxx). Durch Umformatierung kann die Nachkommastelle nicht zurückgeholt werden.

Ich hätte da noch ein zweites Anliegen, bei dem ich ohne Hilfe nicht weiter komme:

Ich habe im Grunde ca. 50 solcher Einzel-Dateien in eine Datei zu importieren. Im Idealfall sollten alle Daten allerdings auf ein Tabellenblatt gelangen und nicht jede Datei ein eigenes Tabellenblatt erhalten. Jede von mir zu importierende Datei hat zwei Spalten (1.Spalte mit Datum und Uhrzeit; 2. Spalte mit Messwert) die immer vollständig zu importieren sind.


Ich bin für jeden Tipp/jede Hilfe dankbar!!!
Grüße Markus
Bitte warten ..
Mitglied: colinardo
11.03.2014, aktualisiert um 11:18 Uhr
Hallo Markus, Willkommen im Forum!
das Problem ist das Excel hier beim Import via Code das englische Zahlenformat benutzt, wenn du bei den Zahlen das Komma durch einen Punkt ersetzt wird es richtig importiert.
Hier aber eine Lösung die das automatisch macht und alle CSV-Daten in ein Sheet untereinander importiert und die Überschriften dabei nicht wiederholt.
Da du oben kein Trennzeichen für die Spalten der CSV-Datei angegeben hast habe ich mal das Semikolon als Trennzeichen genommen (lässt sich in Zeile 19 / zweiter Parameter festlegen). Den Pfad zu den CSV-Dateien legst du in Zeile 3 fest.
Zum starten des Imports muss die Prozedur ImportiereCSVDateien() gestartet werden.

01.
Sub ImportiereCSVDateien() 
02.
    Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer 
03.
    Const CSVPFAD = "E:\csvdateien" 
04.
    Set fso = CreateObject("Scripting.Filesystemobject") 
05.
    Set ws = Worksheets(1) 
06.
    ws.Range("A:ZZ").Clear 
07.
    Set startRange = ws.Range("A1") 
08.
    Set curRange = startRange 
09.
    Application.DisplayAlerts = False 
10.
    counter = 1 
11.
    For Each f In fso.GetFolder(CSVPFAD).Files 
12.
        If LCase(Right(f.Name, 3)) = "csv" Then 
13.
            Dim importHeader As Boolean 
14.
            If counter = 1 Then 
15.
                header = True 
16.
            Else 
17.
                header = False 
18.
            End If 
19.
            importCSV f.Path, ";", curRange, header 
20.
            Set curRange = curRange.End(xlDown).Offset(1, 0) 
21.
            counter = counter + 1 
22.
        End If 
23.
         
24.
    Next 
25.
    ws.ListObjects.Add xlSrcRange, ws.Range(startRange, curRange.Offset(-1, curRange.Offset(-1, 0).End(xlToRight).Column - 1)) 
26.
    Application.DisplayAlerts = True 
27.
    Set fso = Nothing 
28.
End Sub 
29.
 
30.
Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean) 
31.
    Dim intStart As Integer 
32.
    Set fso = CreateObject("Scripting.FileSystemObject") 
33.
    Set regex = CreateObject("vbscript.regexp") 
34.
    patNumber = "^([\d\.,\+\-]+)$" 
35.
    arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare) 
36.
    Set rngCurrent = targetRange 
37.
    If importHeader Then 
38.
        intStart = 0 
39.
    Else 
40.
        intStart = 1 
41.
    End If 
42.
    For i = intStart To UBound(arrLines) 
43.
        If arrLines(i) <> "" Then 
44.
            cols = Split(arrLines(i), delim, -1, vbTextCompare) 
45.
            For c = 0 To UBound(cols) 
46.
                rngCurrent.Offset(0, c).ClearFormats 
47.
                wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare)) 
48.
                ' check for Numberformat 
49.
                regex.Pattern = patNumber 
50.
                Set matches = regex.Execute(wert) 
51.
                If matches.Count > 0 Then 
52.
                    wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare) 
53.
                End If 
54.
                ' set value in cell 
55.
                rngCurrent.Offset(0, c).Value = wert 
56.
            Next 
57.
            Set rngCurrent = rngCurrent.Offset(1, 0) 
58.
        End If 
59.
    Next 
60.
    Set fso = Nothing 
61.
    Set regex = Nothing 
62.
End Function
Grüße Uwe
Bitte warten ..
Mitglied: Zebras
01.04.2014 um 21:44 Uhr
Hi,
dieses Makro ist echt super! Aber ist es auch möglich, an Stelle die Daten untereinander aufzuführen, diese nebeneinander auf zu listen? Wäre sehr dankbar, wenn jemand mir helfen würde =)
Bitte warten ..
Mitglied: colinardo
01.04.2014, aktualisiert um 23:41 Uhr
Zitat von Zebras:

Hi,
dieses Makro ist echt super! Aber ist es auch möglich, an Stelle die Daten untereinander aufzuführen, diese
nebeneinander auf zu listen? Wäre sehr dankbar, wenn jemand mir helfen würde =)
in Teil 2 steht die Lösung für dich parat:
http://www.administrator.de/forum/alle-csv-dateien-in-einem-ordner-mit- ...

Grüße Uwe
Bitte warten ..
Mitglied: Zebras
02.04.2014 um 08:59 Uhr
Perfekt. Vielen vielen Dank. Komm mir zwar etwas blöd vor, dass ich das selbst nicht gesehen habe, aber naja... ^^
Bitte warten ..
Mitglied: KurinoKi
22.08.2014 um 09:56 Uhr
Hallo Uwe,

vielen Dank für das tolle Skript.

Ich war genau danach auf der Suche und es funktioniert auch super, allerdings habe ich leider noch eine Frage dazu und habe mich dafür nun auch extra in diesem Forum angemeldet.

Die Spalten A, C, F, und evtl. noch B und H müssen beim Import als Text formatiert werden, da diese führende Nullen haben.
Wo muss das Skript hierzu angepasst werden. Ich habe leider noch gar keine Erfahrung mit VBA Skript und benötige hier leider Hilfe.

Vielen Dank im voraus.

Grüße,
Stephy
Bitte warten ..
Mitglied: colinardo
22.08.2014, aktualisiert 13.10.2014
Hallo Stephy, Willkommen auf Administrator.de!
vielen Dank für das tolle Skript.
keine Ursache
Die Spalten A, C, F, und evtl. noch B und H müssen beim Import als Text formatiert werden, da diese führende Nullen haben.
Wo muss das Skript hierzu angepasst werden. Ich habe leider noch gar keine Erfahrung mit VBA Skript und benötige hier leider Hilfe.
dazu habe ich dir mal die Import-Funktion angepasst, die die gewünschten Spalten der CSV als Text importiert. Tausche die Funktion einfach durch diese aus:
Die Änderungen findest du in Zeile 25-31
01.
Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean) 
02.
    Dim intStart As Integer 
03.
    Set fso = CreateObject("Scripting.FileSystemObject") 
04.
    Set regex = CreateObject("vbscript.regexp") 
05.
    patNumber = "^([\d\.,\+\-]+)$" 
06.
    arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare) 
07.
    Set rngCurrent = targetRange 
08.
    If importHeader Then 
09.
        intStart = 0 
10.
    Else 
11.
        intStart = 1 
12.
    End If 
13.
    For i = intStart To UBound(arrLines) 
14.
        If arrLines(i) <> "" Then 
15.
            cols = Split(arrLines(i), delim, -1, vbTextCompare) 
16.
            For c = 0 To UBound(cols) 
17.
                rngCurrent.Offset(0, c).ClearFormats 
18.
                wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare)) 
19.
                ' check for Numberformat 
20.
                regex.Pattern = patNumber 
21.
                Set matches = regex.Execute(wert) 
22.
                If matches.Count > 0 Then 
23.
                    wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare) 
24.
                End If 
25.
               ' Spalten A, B, C, D, F, H als Text importieren 
26.
                If c = 0 Or c = 1 Or c = 2 Or c = 5 Or c = 7 Then 
27.
                    rngCurrent.Offset(0, c).NumberFormat = "@" 
28.
                    rngCurrent.Offset(0, c).Value = wert 
29.
                Else 
30.
                    rngCurrent.Offset(0, c).Value = wert 
31.
                End If 
32.
            Next 
33.
            Set rngCurrent = rngCurrent.Offset(1, 0) 
34.
        End If 
35.
    Next 
36.
    Set fso = Nothing 
37.
    Set regex = Nothing 
38.
End Function
Grüße Uwe
Bitte warten ..
Mitglied: KurinoKi
22.08.2014 um 10:40 Uhr
Hallo Uwe,

vielen Dank für die Aufnahme im Forum und die suuuuuper schnell Antwort.


Ich muss leider nochmals eine Frage zu dem Skript stellen.

Ich verwende das 2. Skript mit der Zusammenfassung am Ende, die mir an sich auch schon reichen würde.

Welche der Zeilen aus diesem Skript muss ich durch die Zeilen 25-31 ersetzten.

Wie muss ich dieses Skript abspeichern, damit ich es als Vorlage immer wieder aufrufen kann. Ich habe das bereits versucht aber dann bringt Excel eine Fehlermeldung, dass das Makro nicht verfügbar ist oder deaktiviert.

Für den Import habe ich mir eine Form in meinem Excel erstellt und das Makro zugewiesen, geht dies auch noch auf einem anderen Weg.

Vielen Dank

Viele Grüße
Stephy
Bitte warten ..
Mitglied: colinardo
22.08.2014, aktualisiert um 10:50 Uhr
Zitat von KurinoKi:
Welche der Zeilen aus diesem Skript muss ich durch die Zeilen 25-31 ersetzten.
wenn du das hier meinst Zeile 49.
Wie muss ich dieses Skript abspeichern, damit ich es als Vorlage immer wieder aufrufen kann. Ich habe das bereits versucht aber
dann bringt Excel eine Fehlermeldung, dass das Makro nicht verfügbar ist oder deaktiviert.
Ein Excelsheet mit Makros musst du im *.xlsm Format abspeichern. Wenn das Makro aber global in allen Arbeitsmappen verfügbar sein soll, musst du es als Addin speichern. Dazu gibst du im "Speichern unter" Dialog als Format Excel Addin *.xlam an. Nach dem Abspeichern gehst du in den Excel-Optionen auf AddIns > Button: Gehe zu "Excel-Addins" und fügst dort dein gerade gespeichertes Addin hinzu und aktivierst es mit einem Häkchen.

Grüße Uwe
Bitte warten ..
Mitglied: KurinoKi
22.08.2014 um 11:56 Uhr
Ich verwende diesese Skript

Sub ImportiereCSVDateien()
Const CSVPFAD = "E:\csv-dateien"
Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet
Set fso = CreateObject("Scripting.Filesystemobject")
Set wbTarget = ActiveWorkbook
Application.DisplayAlerts = False
'Lösche alle Worksheets bevor wir alle neu anlegen
While wbTarget.Worksheets.Count > 1
wbTarget.Worksheets(1).Delete
Wend
wbTarget.Worksheets(1).Name = "Zusammenfassung"
wbTarget.Worksheets(1).Range("A:ZZ").Clear
For Each f In fso.GetFolder(CSVPFAD).Files
If LCase(Right(f.Name, 3)) = "csv" Then
Workbooks.OpenText Filename:=f.Path
Set wbSource = ActiveWorkbook
On Error Resume Next
Set ws = wbTarget.Worksheets(f.Name)
If Err <> 0 Then
Set ws = wbTarget.Worksheets.Add
ws.Name = f.Name
ws.Range("A:ZZ").Clear
End If

wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True
wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1")
wbSource.Close False
End If
Next
Set ts = wbTarget.Worksheets("Zusammenfassung")
Dim curCell As Range
Set curCell = ts.Range("A1")
For i = 1 To wbTarget.Worksheets.Count - 1
maxRow = wbTarget.Worksheets(i).Range("A1").End(xlDown).Row
maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column
wbTarget.Worksheets(i).Range(wbTarget.Worksheets(i).Cells(1, 1), wbTarget.Worksheets(i).Cells(maxRow, maxCol)).Copy Destination:=curCell
Set curCell = curCell.End(xlDown).Offset(2, 0)
Next
Application.DisplayAlerts = True
Set fso = Nothing
End Sub
Bitte warten ..
Mitglied: Goki44
13.10.2014 um 17:29 Uhr
Hallo IT Freunde,

ich habe das Script getestet und es läuft wunderbar. Vielen Dank an den Ersteller
Gibt es die Möglichkeit in eine zusätzliche Zeile, links dem Datensatz den Dateinamen von der verwendeten csv Datei zu schreiben?

Viele Grüße
Günter
Bitte warten ..
Mitglied: colinardo
13.10.2014, aktualisiert 05.12.2014
Hallo Goki44, Willkommen auf Administrator.de !
Zitat von Goki44:
ich habe das Script getestet und es läuft wunderbar. Vielen Dank an den Ersteller
Keine Ursache
Gibt es die Möglichkeit in eine zusätzliche Zeile, links dem Datensatz den Dateinamen von der verwendeten csv Datei zu
schreiben?
sicher, guckst du hier:
01.
Sub ImportiereCSVDateien() 
02.
    Const CSVPFAD = "E:\csvdateien" 
03.
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, curCell As Range 
04.
    Set fso = CreateObject("Scripting.Filesystemobject") 
05.
    Set wbTarget = ThisWorkbook 
06.
    Application.DisplayAlerts = False 
07.
    Application.ScreenUpdating = False 
08.
    'Lösche alle Worksheets bevor wir alle neu anlegen 
09.
    While wbTarget.Worksheets.Count > 1 
10.
        wbTarget.Worksheets(1).Delete 
11.
    Wend 
12.
    wbTarget.Worksheets(1).Name = "Zusammenfassung" 
13.
    wbTarget.Worksheets(1).Range("A:ZZ").Clear 
14.
    For Each f In fso.GetFolder(CSVPFAD).Files 
15.
       If LCase(fso.GetExtensionName(f.Name)) = "csv" Then 
16.
            Workbooks.OpenText Filename:=f.Path 
17.
            Set wbSource = ActiveWorkbook 
18.
            On Error Resume Next 
19.
            Set ws = wbTarget.Worksheets.Add(After:=wbTarget.Sheets(wbTarget.Sheets.Count)) 
20.
            ws.Name = f.Name 
21.
            ws.Range("A:ZZ").Clear 
22.
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True 
23.
            wbSource.Worksheets(1).UsedRange.Copy Destination:=ws.Range("A1") 
24.
            wbSource.Close False 
25.
        End If 
26.
    Next 
27.
     
28.
    With wbTarget.Worksheets("Zusammenfassung") 
29.
        Set curCell = .Range("B1") 
30.
        For i = 2 To wbTarget.Worksheets.Count 
31.
            'Inhalt der CSV in das Zusammenfassungs-Sheet kopieren 
32.
            wbTarget.Sheets(i).UsedRange.Copy Destination:=curCell 
33.
            'Name der Quelle in Spalte A schreiben 
34.
            curCell.Offset(0, -1).Value = wbTarget.Sheets(i).Name 
35.
            'Zelle für nächsten Import setzen 
36.
            Set curCell = curCell.Offset(wbTarget.Sheets(i).UsedRange.Rows.Count + 2, 0) 
37.
        Next 
38.
        'Spaltengröße im Zusammenfassungssheet automatisch anpassen 
39.
        .UsedRange.EntireColumn.AutoFit 
40.
        .Select 
41.
    End With 
42.
    Application.DisplayAlerts = True 
43.
    Application.ScreenUpdating = True 
44.
    MsgBox "Vorgang beendet!", vbInformation 
45.
    Set fso = Nothing 
46.
End Sub
Viel Spaß
Grüße Uwe
Bitte warten ..
Mitglied: Goki44
13.10.2014 um 23:14 Uhr
Vielen Dank für die schnelle Rückmeldung
Bitte warten ..
Mitglied: miregalwie
14.11.2014 um 15:05 Uhr
Wie kann ich dieses Makro (welches übrigens super funktioniert) so modifizieren, dass es mir aus den geöffneten csv-Dateien bestimmte Bereiche (Zelle B5, C12-C14 und G15-G59) kopiert ohne ein Extrablatt in meiner Arbeitmappe anzulegen und im Datenblatt "Zusammenfassung" einfügt. Dabei sollen die Daten aus der 1. csv-Datein in Zeile 1 kopiert werden, die aus der 2. csv-Datei in Zeile 2 usw. Bis es in dem Ordner keine csv-Dateien mehr gibt, d.h. die Anzahl der csv-Dateien ist variabel. Ich versuche schon seit 4 Tagen mein Glück, aber Excel scheint nicht mit mir arbeiten zu wollen.
Bitte warten ..
Mitglied: colinardo
14.11.2014, aktualisiert um 17:30 Uhr
@miregalwie
bitte schaue für deine Anfrage in deine "persönlichen Nachrichten".
Bitte warten ..
Mitglied: waslozzya
05.12.2014, aktualisiert um 16:12 Uhr
Hallo Uwe,

das Makro ist wirklich klasse!
Habe es eingebunden und es erfüllt auch schon fast meine Anforderungen.

Mein Problem ist, dass ich lediglich die "Zusammenfassungs"-Tabelle haben möchte und sonst keine einzelnen Tabellenblätter.
Habe es bisher so geregelt, dass ich einfach an den obigen Code herangehängt habe, dass eben wieder die für mich überflüssigen anderen Tabellenblätter gelöscht werden.
Aus Performance Gründen wäre es natürlich besser, wenn die Tabellenblätter zuvor garnicht erst erstellt werden sondern der Inhalt der CSV-Dateien von Anfang an bloß in das "Zusammenfassungs"-Blatt untereinander hinweg kopiert werden.

Kannst du mir da behilflich sein? Bin mittlerweile schon am verzweifeln, da ich es leider selbst nicht hinbekomme.

Grüße

EDIT: Es handelt sich um folgendes Makro:

01.
 
02.
Sub ImportiereCSVDateien() 
03.
    Const CSVPFAD = "E:\csv-dateien" 
04.
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet, ts As Worksheet 
05.
    Set fso = CreateObject("Scripting.Filesystemobject") 
06.
    Set wbTarget = ActiveWorkbook 
07.
    Application.DisplayAlerts = False 
08.
    'Lösche alle Worksheets bevor wir alle neu anlegen 
09.
    While wbTarget.Worksheets.Count > 1 
10.
            wbTarget.Worksheets(1).Delete 
11.
    Wend 
12.
    wbTarget.Worksheets(1).Name = "Zusammenfassung" 
13.
    wbTarget.Worksheets(1).Range("A:ZZ").Clear 
14.
    For Each f In fso.GetFolder(CSVPFAD).Files 
15.
        If LCase(Right(f.Name, 3)) = "csv" Then 
16.
            Workbooks.OpenText Filename:=f.Path 
17.
            Set wbSource = ActiveWorkbook 
18.
            On Error Resume Next 
19.
            Set ws = wbTarget.Worksheets(f.Name) 
20.
            If Err <> 0 Then 
21.
                Set ws = wbTarget.Worksheets.Add 
22.
                ws.Name = f.Name 
23.
                ws.Range("A:ZZ").Clear 
24.
            End If 
25.
         
26.
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True 
27.
            wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1") 
28.
            wbSource.Close False 
29.
        End If 
30.
    Next 
31.
    Set ts = wbTarget.Worksheets("Zusammenfassung") 
32.
    Dim curCell As Range 
33.
    Set curCell = ts.Range("A1") 
34.
    For i = 1 To wbTarget.Worksheets.Count - 1 
35.
        maxRow = wbTarget.Worksheets(i).Range("A1").End(xlDown).Row 
36.
        maxCol = wbTarget.Worksheets(i).Range("A1").End(xlToRight).Column 
37.
        wbTarget.Worksheets(i).Range(wbTarget.Worksheets(i).Cells(1, 1), wbTarget.Worksheets(i).Cells(maxRow, maxCol)).Copy Destination:=curCell 
38.
        Set curCell = curCell.End(xlDown).Offset(2, 0) 
39.
    Next 
40.
    Application.DisplayAlerts = True 
41.
    Set fso = Nothing 
42.
End Sub 
43.
 
Bitte warten ..
Mitglied: Schmare
18.11.2015 um 09:10 Uhr
Hallo "colinardo",

ich habe leider noch kaum Kontakt mit Visaul Basic und bin über stundenlange Suche auf diesen älteren Thread gestoßen, der meiner Problemlösung am nächsten kommt. Zum Thema an sich gibt es ja mehrere, die aber immer unterschiedliche Zielformatierungen behandeln.

Hab den Code kopiert aber da ich in meinen csv Dateien zwei Zeilen Überschrift habe, funktioniert es nicht.

Aufgrund meines mangelnden Wissens, schaffe ich es nicht mal den Code so umzuschreiben, dass ich meine csv mit zweizeiliger Überschrift in einer Excel Tabellenblatt zusammenfahren kann.

BESCHREIBUNG DES ABLAUFS
Die erste Datei wird mit dem code incl. der beiden Überschriftszeilen korrekt eingelesen.
Ergebnis: Zwei Überschriften, eine dritte Zeile mit Werten
Bei der Zweite csv wird ohne die erste Überschriftszeile in Tabellenzeile 3 eingelesen und überschreibt somit die Werte aus der ersten csv.
Beim einlesen der dritten csv kommt der Fehler "Anwednungs- oder objektdefinierter Fehler"

Könntest du mir da behilflich sein?




Grüße
Michael
Bitte warten ..
Mitglied: BlackHell
03.12.2015 um 12:00 Uhr
Moin!

Erstmal vielen Dank für das Script.

Zur Sache mit den 2 Headerzeilen habe ich folgenden Vorschlag:

01.
If Counter  <= 2 Then 
02.
      Header = True 
03.
Else  
04.
      Header = False 
05.
End If
In der Funktion importCSV muss dann auch der Zeilenstart angepasst werden.
01.
If ImportHeader Then 
02.
      intStart = 0 
03.
Else 
04.
      intStart = 2 
05.
End If
Meine Herausforderung ist eine andere.
Ich wollte bei
01.
arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare)
folgende Ergänzung machen, um dort meine ANSI Codierte Datei einlesen zu können, bzw zwischen UTF-8 und ANSI wechseln zu können.
01.
arrLines = Split(fso.OpenTextFile(strPatch, 1, ForReading, TristateFalse).ReadAll(), vbNewLine, -1, vbTextCompare)
Leider klappt das nicht.
Entweder bekomme ich, vermutlich, Chinesische Schriftzeichen, oder ich habe im Text komische Zeichen, wo diese nicht hingehören.

Ich lese mehrere csv Dateien ein. Diese müssen zusammengefasst werden ohne doppelte Header und als eine CSV Datei wieder in einem bestimmten Format und mit einem bestimmten Dateinamen abgespeichert werden. Dann benötige ich die Informationen aus der letzten Spalte, die über eine ZählenWenn Funktion ausgewertet werden und in einem anderen Tabellenblatt immer als Zeile 2 eingefügt werden sollen. Die schon vorhandenen sollen dann jeweils nach unten verschoben werden.

Da ich hier nur das 2003er Office habe, bin ich auf die vorhandenen Möglichkeiten beschränkt.

BlackHell
Bitte warten ..
Mitglied: superspacer-2000
10.01.2016 um 17:18 Uhr
Hallo Uwe,

ich habe das obige Script ausprobiert und es importiert auch die Daten.

Aber dann erscheint "Laufzeitfehler 1004" und die Zeile 20 ist gelb unterlegt.

Gibt es dafür eine Lösung?

Danke schon mal im Voraus, ich bin eher Laie, was Makros angeht.

Gruß

Steffen
Bitte warten ..
Mitglied: interface31
15.08.2016 um 09:49 Uhr
Hi Uwe,

habe dein Code mal angewendet.
Habe eine Vorlage mit drei Sheets.
Mein Problem ist das, das ein neues Sheet angelegt wird und es nicht in das Daten Sheet eingefügt wird.
Dazu soll zu jedem CSV File ein eigenes File erzeugt werden zu der Vorlage.


01.
Sub ImportiereCSVDateien() 
02.
    Const CSVPFAD = "C:\Z_Test\" 
03.
    Dim wbTarget As Workbook, wbSource As Workbook, ws As Worksheet 
04.
    Set fso = CreateObject("Scripting.Filesystemobject") 
05.
    Set wbTarget = ActiveWorkbook 
06.
    Application.DisplayAlerts = False 
07.
    'Lösche alle Worksheets bevor wir alle neu anlegen 
08.
    'If wbTarget.Worksheets.Count > 1 Then 
09.
        'For i = 1 To wbTarget.Worksheets.Count - 1 
10.
       '     wbTarget.Worksheets(i).Delete 
11.
      '  Next 
12.
    'End If 
13.
    For Each f In fso.GetFolder(CSVPFAD).Files 
14.
        If LCase(Right(f.Name, 3)) = "csv" Then 
15.
            Workbooks.OpenText Filename:=f.Path 
16.
            Set wbSource = ActiveWorkbook 
17.
            On Error Resume Next 
18.
            Set ws = wbTarget.Worksheets(f.Name) 
19.
            If Err <> 0 Then 
20.
                Set ws = wbTarget.Worksheets.Add 
21.
                ws.Name = f.Name 
22.
                ws.Range("A:ZZ").Clear 
23.
            End If 
24.
         
25.
            wbSource.Worksheets(1).Range("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Semicolon:=True, TrailingMinusNumbers:=True 
26.
            wbSource.Worksheets(1).Range("A:ZZ").Copy Destination:=ws.Range("A1") 
27.
            wbSource.Close False 
28.
        End If 
29.
    Next 
30.
    Application.DisplayAlerts = True 
31.
    Set fso = Nothing 
32.
End Sub 
33.
 
Bitte warten ..
Mitglied: colinardo
15.08.2016, aktualisiert um 11:30 Uhr
Hi,
ist ja auch logisch denn der obige Code erstellt für jede CSV Datei ein neues Sheet, der macht nichts anderes...!
Die anderen Varianten, ob untereinander in einem Sheet zusammengefasst oder nebeneinander etc. pp ... Findest du von mir schon hier im Forum bis zum Abwinken :

Grüße Uwe
Bitte warten ..
Mitglied: interface31
19.08.2016 um 15:36 Uhr
Ok gut aber wie bekomme ich es hin das in meiner Vorlage das einzelne CSV eingelesen werden kann?

01.
Sub ImportCSVFromFolder() 
02.
    Dim wsTemp As Worksheet, wsTarget As Worksheet, curCell As Range, CSVPFAD As String, fso As Object, f As Object, strCSVDelimiter As String 
03.
     
04.
    With Application.FileDialog(msoFileDialogFolderPicker) 
05.
        .InitialFileName = "C:\Z_Test\M176" 
06.
        .Title = "Ordnerauswahl" 
07.
        .ButtonName = "Auswahl..." 
08.
        .InitialView = msoFileDialogViewList 
09.
        If .Show = -1 Then 
10.
            CSVPFAD = .SelectedItems(1) 
11.
        Else 
12.
            Exit Sub 
13.
        End If 
14.
    End With 
15.
     
16.
    'Legt das CSV-Trennzeichen für die Dateien fest 
17.
    strCSVDelimiter = ";" 
18.
     
19.
    Set fso = CreateObject("Scripting.Filesystemobject") 
20.
    Application.DisplayAlerts = False 
21.
    Application.ScreenUpdating = False 
22.
     
23.
    'Zielarbeitsblatt für die importierten Daten 
24.
    Set wsTarget = Worksheets(1) 
25.
    wsTarget.Name = "Zusammenfassung" 
26.
    'temporäres Arbeitsblatt für den Import der Daten erstellen 
27.
    Set wsTemp = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
28.
     
29.
    'Inhalt des Zusammenfassungsblattes löschen 
30.
    wsTarget.UsedRange.Clear 
31.
     
32.
    'Startausgabezelle festlegen 
33.
    Set curCell = wsTarget.Range("A1") 
34.
    For Each f In fso.GetFolder(CSVPFAD).Files 
35.
        If LCase(fso.GetExtensionName(f.Name)) = "csv" Then 
36.
            'Temporäres Sheet löschen 
37.
            wsTemp.UsedRange.Clear 
38.
            'CSV-Daten in Temporäres Sheet importieren 
39.
            With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & f.Path, Destination:=wsTemp.Range("$A$1")) 
40.
                .Name = "import" 
41.
                .FieldNames = True 
42.
                .AdjustColumnWidth = True 
43.
                .RefreshPeriod = 0 
44.
                .TextFilePlatform = xlWindows 
45.
                .TextFileStartRow = 1 
46.
                .TextFileParseType = xlDelimited 
47.
                .TextFileTextQualifier = xlTextQualifierDoubleQuote 
48.
                .TextFileOtherDelimiter = strCSVDelimiter 
49.
                .Refresh BackgroundQuery:=False 
50.
                .Delete 
51.
            End With 
52.
             
53.
            With wsTemp 
54.
                'Daten in Zielsheet kopieren 
55.
                .UsedRange.Copy curCell 
56.
            End With 
57.
            'Ausgabezeile eins nach unten schieben 
58.
            Set curCell = wsTarget.Cells(wsTarget.UsedRange.Rows.Count + 2, 1) 
59.
        End If 
60.
    Next 
61.
    'Temporäres Sheet löschen 
62.
    wsTemp.Delete 
63.
    'Spalten anpassen 
64.
    wsTarget.Columns.AutoFit 
65.
     
66.
    Application.DisplayAlerts = True 
67.
    Application.ScreenUpdating = True 
68.
    MsgBox "Vorgang beendet!", vbInformation 
69.
    Set fso = Nothing 
70.
End Sub
Mit diesem Coden bekomme ich alle in ein Excelfile was auch ok wäre aber anderen Aufbau dann nach sich zieht
Bitte warten ..
Mitglied: colinardo
19.08.2016, aktualisiert um 16:13 Uhr
Zitat von interface31:
Ok gut aber wie bekomme ich es hin das in meiner Vorlage das einzelne CSV eingelesen werden kann?
Indem du den "FolderPicker" durch einen msoFileDialogOpen ersetzt und die Schleife durch eine Itteration über die Dialogauswahl ersetzt

01.
Sub ImportCSVFromFiles() 
02.
    Dim wsTemp As Worksheet, wsTarget As Worksheet, curCell As Range, CSVFILES As Object, strCSVDelimiter As String 
03.
     
04.
    With Application.FileDialog(msoFileDialogOpen) 
05.
        .Title = "CSV-Dateien wählen" 
06.
        .ButtonName = "Auswahl..." 
07.
        .InitialView = msoFileDialogViewList 
08.
        .Filters.Add "CSV-Dateien", "*.csv", 1 
09.
        .AllowMultiSelect = True 
10.
        If .Show = -1 Then 
11.
            Set CSVFILES = .SelectedItems 
12.
        Else 
13.
            Exit Sub 
14.
        End If 
15.
    End With 
16.
     
17.
     
18.
    'Legt das CSV-Trennzeichen für die Dateien fest 
19.
    strCSVDelimiter = ";" 
20.
     
21.
    Application.DisplayAlerts = False 
22.
    Application.ScreenUpdating = False 
23.
     
24.
    'Zielarbeitsblatt für die importierten Daten 
25.
    Set wsTarget = Worksheets(1) 
26.
    wsTarget.Name = "Zusammenfassung" 
27.
    'temporäres Arbeitsblatt für den Import der Daten erstellen 
28.
    Set wsTemp = Worksheets.Add(After:=Worksheets(Worksheets.Count)) 
29.
     
30.
    'Inhalt des Zusammenfassungsblattes löschen 
31.
    wsTarget.UsedRange.Clear 
32.
     
33.
    'Startausgabezelle festlegen 
34.
    Set curCell = wsTarget.Range("A1") 
35.
    For i = 1 To CSVFILES.Count 
36.
 
37.
        'Temporäres Sheet löschen 
38.
        wsTemp.UsedRange.Clear 
39.
        'CSV-Daten in Temporäres Sheet importieren 
40.
        With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & CSVFILES.Item(i), Destination:=wsTemp.Range("$A$1")) 
41.
            .Name = "import" 
42.
            .FieldNames = True 
43.
            .AdjustColumnWidth = True 
44.
            .RefreshPeriod = 0 
45.
            .TextFilePlatform = xlWindows 
46.
            .TextFileStartRow = 1 
47.
            .TextFileParseType = xlDelimited 
48.
            .TextFileTextQualifier = xlTextQualifierDoubleQuote 
49.
            .TextFileOtherDelimiter = strCSVDelimiter 
50.
            .Refresh BackgroundQuery:=False 
51.
            .Delete 
52.
        End With 
53.
         
54.
        'Daten in Zielsheet kopieren 
55.
        wsTemp.UsedRange.Copy curCell 
56.
         
57.
        'Ausgabezeile eins nach unten schieben 
58.
        Set curCell = wsTarget.Cells(wsTarget.UsedRange.Rows.Count + 2, 1) 
59.
    Next 
60.
    'Temporäres Sheet löschen 
61.
    wsTemp.Delete 
62.
    'Spalten anpassen 
63.
    wsTarget.Columns.AutoFit 
64.
     
65.
    Application.DisplayAlerts = True 
66.
    Application.ScreenUpdating = True 
67.
    MsgBox "Vorgang beendet!", vbInformation 
68.
End Sub
Bitte warten ..
Mitglied: interface31
23.08.2016 um 15:10 Uhr
Danke klappt soweit.
Bekomme ich das aber auch automatisiert, so dass ich sage öffne die 100 csv files und speichere sie mit der Vorlage neu ab unter den Namen vom Sheet 1 Celle A1?
Bitte warten ..
Mitglied: colinardo
23.08.2016, aktualisiert um 18:09 Uhr
Öhm willst du mich jetzt veräppeln ?? Die vorherige Variante hat doch schon automatisch alle Files eines Ordners verarbeitet. Machen kann ich alles, aber das ist hier ja kein Wunschkonzert! Wenn du eine individuelle Anpassung brauchst kannst du mich gerne per PM kontaktieren und in mache dir dann ein Angebot dazu.
Wenn du das nicht willst, Code hast du jetzt eigentlich zur Genüge um das auch selbst zu realisieren.

p.s. Das Übernehmen von Fragen ist hier eigentlich nicht gern gesehen.
Bitte warten ..
Mitglied: Biber
23.08.2016 um 19:39 Uhr
[OT]

Zitat von colinardo:

p.s. Das übernehmen von Fragen ist hier eigentlich nicht gern gesehen.
Und es kostet auch meist mehrere Anläufe, bis es zum Übelnehmen von Fragen kommt.

Grüße
Biber

P.S. Aber bevor es hier lauter wird:
Ich denke, es stehen hier jetzt auch für einen Einsteiger genug Ansätze, um die gewünschte Variation in endlicher Zeit und einem Minimum an Koffein oder anderen Drogen ins Ziel zu bringen. Büschen mehr Mut, interface31. Wenn es garnienich klappt, melde dich nochmal. Ansonsten würde ich den TO-losen Beitrag gerne schliessen.

[/OT]
Bitte warten ..
Mitglied: JoSiBa
15.09.2016, aktualisiert um 11:34 Uhr
Hallo Colinardo,

ich benutze diese Version deines Codes:
01.
Sub ImportiereCSVDateien() 
02.
    Dim ws As Worksheet, header As Boolean, startRange As Range, curRange As Range, counter As Integer 
03.
    Const CSVPFAD = "E:\Datenbank" 
04.
    Set fso = CreateObject("Scripting.Filesystemobject") 
05.
    Set ws = Worksheets(1) 
06.
    ws.Range("A:ZZ").Clear 
07.
    Set startRange = ws.Range("A1") 
08.
    Set curRange = startRange 
09.
    Application.DisplayAlerts = False 
10.
    counter = 1 
11.
    For Each f In fso.GetFolder(CSVPFAD).Files 
12.
        If LCase(Right(f.Name, 3)) = "csv" Then 
13.
            Dim importHeader As Boolean 
14.
            If counter = 1 Then 
15.
                header = True 
16.
            Else 
17.
                header = False 
18.
            End If 
19.
            importCSV f.Path, ";", curRange, header 
20.
            Set curRange = curRange.End(xlDown).Offset(1, 0) 
21.
            counter = counter + 1 
22.
        End If 
23.
         
24.
    Next 
25.
    ws.ListObjects.Add xlSrcRange, ws.Range(startRange, curRange.Offset(-1, curRange.Offset(-1, 0).End(xlToRight).Column - 1)) 
26.
    Application.DisplayAlerts = True 
27.
    Set fso = Nothing 
28.
End Sub 
29.
 
30.
Function importCSV(strPath, delim, ByVal targetRange As Range, ByVal importHeader As Boolean) 
31.
    Dim intStart As Integer 
32.
    Set fso = CreateObject("Scripting.FileSystemObject") 
33.
    Set regex = CreateObject("vbscript.regexp") 
34.
    patNumber = "^([\d\.,\+\-]+)$" 
35.
    arrLines = Split(fso.OpenTextFile(strPath, 1).ReadAll(), vbNewLine, -1, vbTextCompare) 
36.
    Set rngCurrent = targetRange 
37.
    If importHeader Then 
38.
        intStart = 0 
39.
    Else 
40.
        intStart = 1 
41.
    End If 
42.
    For i = intStart To UBound(arrLines) 
43.
        If arrLines(i) <> "" Then 
44.
            cols = Split(arrLines(i), delim, -1, vbTextCompare) 
45.
            For c = 0 To UBound(cols) 
46.
                rngCurrent.Offset(0, c).ClearFormats 
47.
                wert = Trim(Replace(cols(c), """", "", 1, -1, vbTextCompare)) 
48.
                ' check for Numberformat 
49.
                regex.Pattern = patNumber 
50.
                Set matches = regex.Execute(wert) 
51.
                If matches.Count > 0 Then 
52.
                    wert = Replace(matches(0).Submatches(0), ",", ".", 1, -1, vbTextCompare) 
53.
                End If 
54.
                ' set value in cell 
55.
                rngCurrent.Offset(0, c).Value = wert 
56.
            Next 
57.
            Set rngCurrent = rngCurrent.Offset(1, 0) 
58.
        End If 
59.
    Next 
60.
    Set fso = Nothing 
61.
    Set regex = Nothing 
62.
End Function
Die Importierung an sich Funktioniert.

Ich habe hier nur 4 Anliegen.

1) Die Datenbank wird im mom auf "Worksheets(1)" eingelesen, ist es möglich das es immer in den "Tabellenblatt : Datenbank)" eingelesen wird, egal ob es das 2,3,4 Tabellenblatt ist.

2) Datenbank Tabellenname wird als "Tabelle3" eingetragen, ist es möglich diese zu Ändern in "Master_DB".

3) Noch eine Frage, beim Importieren, werden nur die Spalten A:L als Datenbank eingelesen, die restlichen M:AG werden nicht mehr als Datenbank sonder als normale Tabelle.

4) In den Spalten "D:E" sind Datum und Uhrzeit als "UNIX Timestamp" vorhanden, diese sollen beim Importieren in den Format (DD.MM.JJJJ HH:MM) umgewandelt werden.
Was muss im Code geändert werden? Kannst du mir hier helfen?
Bitte warten ..
Mitglied: JoKa0804
02.11.2016 um 16:04 Uhr
Hallo und HILFÄ!
ich bin ein absoluter Laie! Das VBA von Colinardo 29.08.2013 um 11:49 Uhr (CSV importieren und eine Zusammenfassungsseite) ist klasse, funktioniert bei mir leider nicht vollständig. In den CSV-Dateien, die ich benutze ist eigentlich alles nach Spalten ordentlich aufgeteilt (keine Trennung nach Semikolon). In Spalte "L" stehen allerdings Beträge (mit Komma). Das VBA befüllt ab dem Komma des Betrages und die Nachkommastellen nicht mehr und auch jede Spalte danach ist leer. Kann mit bitte jemand helfen? Ich brauche dafür bitte das vollständige VBA (Fragmente helfen mir leider nicht)
Danke!!!!!
Bitte warten ..
Neuester Wissensbeitrag
Internet

Unbemerkt - Telekom Netzumschaltung!

(3)

Erfahrungsbericht von ashnod zum Thema Internet ...

Ähnliche Inhalte
Microsoft Office
Alle CSV-Dateien mit neuem Datum in einem Ordner mit einem VBA Makro einlesen (1)

Frage von parlermo2102 zum Thema Microsoft Office ...

VB for Applications
gelöst Mehrere CSV Dateien aus verschiedenen Ordner einlesen via VBA (12)

Frage von mtufangil zum Thema VB for Applications ...

Microsoft Office
gelöst CSV-Datei mit einem VBA Makro in Excel einlesen und leicht anpassen (5)

Frage von JoSiBa zum Thema Microsoft Office ...

Heiß diskutierte Inhalte
Switche und Hubs
Trunk für 2xCisco Switch. Wo liegt der Fehler? (15)

Frage von JayyyH zum Thema Switche und Hubs ...

DSL, VDSL
DSL-Signal bewerten (13)

Frage von SarekHL zum Thema DSL, VDSL ...