Office: Exel Dateien (aus Unterordnern) zusammenfassen

Helfe beim Thema Exel Dateien (aus Unterordnern) zusammenfassen in Microsoft Excel Hilfe um das Problem gemeinsam zu lösen; Mach mal ne Skizze wie die Ordner / Unterordner vorliegen und wie sie heißen. Sind mehrere txt-Dateien pro Ordner? Sind Dateien in Über und Unterordnern? Dieses Thema im Forum "Microsoft Excel Hilfe" wurde erstellt von JUMPER15, 15. Februar 2015.

Seite 3 von 4

XLPH

xlph

Exel Dateien (aus Unterordnern) zusammenfassen

Mach mal ne Skizze wie die Ordner / Unterordner vorliegen und wie sie heißen.
Sind mehrere txt-Dateien pro Ordner? Sind Dateien in Über und Unterordnern?

xlph, 28. April 2016

#31
MARCCC

MarcCC

Hallo,

die Dateien sind nur in den Unterordnern, es können mehrere Dateien sein, es sollten alle Dateien aus den jeweiligen Unterordnern in ein Tabellenblatt zusammengefasst werden, diese können GS, TS und TE heissen. Also sollen die Dateien letztendlich aus den Ordnern M1-M4 in drei Tabellenblätter (GS,TS,TE)gesplitet mit semicolon, also die Struktur sieht so aus:

M1
-> GS_1_...
-> Dateien mit unterschiedlichen Namen
bis
-> GS_4_...
-> Dateien mit unterschiedlichen Namen
-> TS_1_...
-> Dateien mit unterschiedlichen Namen
bis
-> TS_8_...
-> Dateien mit unterschiedlichen Namen

M2
-> TE_1_...
-> Dateien mit unterschiedlichen Namen
bis
-> TE_4_...
-> Dateien mit unterschiedlichen Namen

M3
-> GS_1_...
-> Dateien mit unterschiedlichen Namen
bis
-> GS_4_...
-> Dateien mit unterschiedlichen Namen
-> TS_1_...
-> Dateien mit unterschiedlichen Namen
bis
-> TS_8_...
-> Dateien mit unterschiedlichen Namen

M4
-> TS_1_...
-> Dateien mit unterschiedlichen Namen
bis
-> TS_4_...
-> Dateien mit unterschiedlichen Namen

Danke schon mal vorab.

MarcCC, 28. April 2016

#32
MARCCC

MarcCC

Hier noch mal ein screenshot.

MarcCC, 1. Mai 2016

#33
XLPH

xlph

Exel Dateien (aus Unterordnern) zusammenfassen

...das kostet dich ein Kasten Bier...

Code:

Option Explicit

Public Sub Import_TXT()

Dim fso As Object
Dim acolPath() As Collection
Dim strPathStart As String

Dim vntFolderSearch As Variant
Dim iacolPath As Long
Dim lngIndex As Long

Dim strTextTmp As String
Dim astrText() As String

Dim strWksName As String

strPathStart = "E:\Neuer Ordner (2)\" ' Anpassen ****

vntFolderSearch = Array("GS_", "TS_", "TE_")

ReDim astrText(LBound(vntFolderSearch) To UBound(vntFolderSearch))
ReDim acolPath(LBound(vntFolderSearch) To UBound(vntFolderSearch))

For lngIndex = LBound(vntFolderSearch) To UBound(vntFolderSearch)
Set acolPath(lngIndex) = New Collection
Next

Set fso = CreateObject("Scripting.FileSystemObject")
Call FilePaths(fso, strPathStart, acolPath, vntFolderSearch, ".txt")
Set fso = Nothing

For lngIndex = LBound(acolPath) To UBound(acolPath)
For iacolPath = 1 To acolPath(lngIndex).Count
'Debug.Print acolPath(lngIndex)(iacolPath)
strTextTmp = ReadTxtFile(acolPath(lngIndex)(iacolPath))
If strTextTmp "" Then
If iacolPath = 1 Then
astrText(lngIndex) = astrText(lngIndex) & strTextTmp
Else
astrText(lngIndex) = astrText(lngIndex) & Split(strTextTmp, vbNewLine, 2)(1) ' Ohne Header
End If
End If
Next
Next
Erase acolPath

For lngIndex = LBound(astrText) To UBound(astrText)

Call ZwischenablageSchreiben(astrText(lngIndex))

strWksName = Replace(vntFolderSearch(lngIndex), "_", "")

With ThisWorkbook.Worksheets(strWksName)
.UsedRange.Clear
.Paste .Range("A1")
End With

Next

End Sub

Public Sub FilePaths(fso As Object, strPath As String, colPath() As Collection, Optional avntFolderSearch As Variant, Optional strFileType As String)

Dim fo As Object, fi As Object, sfo As Object, iavntFolderSearch As Long, lngIndexFound As Long

Set fo = fso.GetFolder(strPath)

lngIndexFound = -1

For iavntFolderSearch = LBound(avntFolderSearch) To UBound(avntFolderSearch)
If InStr(1, fo.Name, avntFolderSearch(iavntFolderSearch), vbTextCompare) = 1 Then
lngIndexFound = iavntFolderSearch: Exit For
End If
Next

If lngIndexFound > -1 Then

For Each fi In fo.Files
If LCase$(fi.Name) Like "*" & strFileType Then
colPath(lngIndexFound).Add fi.Path
End If
Next
Set fi = Nothing

End If

For Each sfo In fo.SubFolders
Call FilePaths(fso, sfo.Path, colPath, avntFolderSearch, strFileType)
Next

Set fo = Nothing

End Sub

Function ReadTxtFile(ByRef Path As String) As String
Dim intFF As Long

' Falls ohne Inhalt, abbrechen
On Error Resume Next
If FileLen(Path) = 0 Then Exit Function
On Error GoTo 0

' Datei lesen
intFF = FreeFile()
Open Path For Binary As #intFF
ReadTxtFile = Space$(LOF(intFF))
Get #intFF, , ReadTxtFile
Close #intFF
End Function

' Sie benötigen einen Verweis auf die
' [Microsoft Forms 2.0 Objektlibrary]
' (Sollte Sie diese nicht so einfach finden, einfach eine Userform einfügen und dann wieder entfernen)

Private Sub ZwischenablageSchreiben(ByVal strText As String)
Dim objDataObject As DataObject

On Error Resume Next

Set objDataObject = New DataObject
objDataObject.SetText strText
objDataObject.PutInClipboard

Set objDataObject = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph, 1. Mai 2016

#34
MARCCC

MarcCC

Du bist mein Held,

funzt super.
die Textdateien sind mit Semikolon getrennt, kannst du das noch enfügen, das die in den Tabellen aufgesplittet werden?
Da würd ich noch einen Kasten raufstellen.*Smilie
... und ich besorg einen Gutschein von Getränke Hoffmann....

Marc

MarcCC, 1. Mai 2016

#35
XLPH

xlph

Du bist mein Held
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

...das ist blöd, Helden sterben am Schluss immer..

Code:

For lngIndex = LBound(acolPath) To UBound(acolPath)
For iacolPath = 1 To acolPath(lngIndex).Count
'Debug.Print acolPath(lngIndex)(iacolPath)
strTextTmp = ReadTxtFile(acolPath(lngIndex)(iacolPath))
strTextTmp = Replace(strTextTmp, ";", vbTab)
If strTextTmp "" Then
If iacolPath = 1 Then
astrText(lngIndex) = astrText(lngIndex) & strTextTmp
Else
astrText(lngIndex) = astrText(lngIndex) & Split(strTextTmp, vbNewLine, 2)(1) ' Ohne Header
End If
End If
Next
Next
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph, 2. Mai 2016

#36
MARCCC

MarcCC

... aber bis dahin haben sie eine verdammt geile Zeit...*grins

vielen Dank.

schick mal ne pn wegen der Biere.

MarcCC, 2. Mai 2016

#37
MARCCC

MarcCC

Exel Dateien (aus Unterordnern) zusammenfassen

Hallo xlph,

ich noch mal, bei der Weiterverarbeitung ist mir aufgefallen, das Excel mein Zahlenformat mal so mal so interpretiert.
Original 1300,1234 wird mal richtig übernommen, mal kommt aber auch 13.001.234 raus und das immer munter gemischt.

Kannst du mir bitte beim Import alles auf Text setzen. Die Formtierung der Spalten wird beim Neustart leider nicht übernommen.

vorab schon mal Danke.

MarcCC, 2. Mai 2016

#38
XLPH

xlph

Lad die betreffendeTextdatei hoch

xlph, 3. Mai 2016

#39
MARCCC

MarcCC

Ich habe sie hochgeladen, es sind immer die Werte in den letzten beiden Spalten.

MarcCC, 3. Mai 2016

#40
XLPH

xlph

Da sonst niergends Kommata vorhanden sind ersetzen wir die durch einen Punkt.

Code:

Option Explicit

Public Sub Import_TXT()

Dim fso As Object
Dim acolPath() As Collection
Dim strPathStart As String

Dim vntFolderSearch As Variant
Dim iacolPath As Long
Dim lngIndex As Long

Dim strTextTmp As String
Dim astrText() As String

Dim strWksName As String

strPathStart = "E:\Neuer Ordner (2)\" ' Anpassen ****

vntFolderSearch = Array("GS_", "TS_", "TE_")

ReDim astrText(LBound(vntFolderSearch) To UBound(vntFolderSearch))
ReDim acolPath(LBound(vntFolderSearch) To UBound(vntFolderSearch))

For lngIndex = LBound(vntFolderSearch) To UBound(vntFolderSearch)
Set acolPath(lngIndex) = New Collection
Next

Set fso = CreateObject("Scripting.FileSystemObject")
Call FilePaths(fso, strPathStart, acolPath, vntFolderSearch, ".txt")
Set fso = Nothing

For lngIndex = LBound(acolPath) To UBound(acolPath)
For iacolPath = 1 To acolPath(lngIndex).Count
'Debug.Print acolPath(lngIndex)(iacolPath)
strTextTmp = ReadTxtFile(acolPath(lngIndex)(iacolPath))
strTextTmp = Replace(strTextTmp, ";", vbTab)
strTextTmp = Replace(strTextTmp, ",", ".")
If strTextTmp "" Then
If iacolPath = 1 Then
astrText(lngIndex) = astrText(lngIndex) & strTextTmp
Else
astrText(lngIndex) = astrText(lngIndex) & Split(strTextTmp, vbNewLine, 2)(1) ' Ohne Header
End If
End If
Next
Next
Erase acolPath

For lngIndex = LBound(astrText) To UBound(astrText)

If astrText(lngIndex) "" Then

Call ZwischenablageSchreiben(astrText(lngIndex))

strWksName = Replace(vntFolderSearch(lngIndex), "_", "")

With ThisWorkbook.Worksheets(strWksName)
.UsedRange.Clear
.Paste .Range("A1")
End With

End If

Next

End Sub

Public Sub FilePaths(fso As Object, strPath As String, colPath() As Collection, Optional avntFolderSearch As Variant, Optional strFileType As String)

Dim fo As Object, fi As Object, sfo As Object, iavntFolderSearch As Long, lngIndexFound As Long

Set fo = fso.GetFolder(strPath)

lngIndexFound = -1

For iavntFolderSearch = LBound(avntFolderSearch) To UBound(avntFolderSearch)
If InStr(1, fo.Name, avntFolderSearch(iavntFolderSearch), vbTextCompare) = 1 Then
lngIndexFound = iavntFolderSearch: Exit For
End If
Next

If lngIndexFound > -1 Then

For Each fi In fo.Files
If LCase$(fi.Name) Like "*" & strFileType Then
colPath(lngIndexFound).Add fi.Path
End If
Next
Set fi = Nothing

End If

For Each sfo In fo.SubFolders
Call FilePaths(fso, sfo.Path, colPath, avntFolderSearch, strFileType)
Next

Set fo = Nothing

End Sub

Function ReadTxtFile(ByRef Path As String) As String
Dim intFF As Long

' Falls ohne Inhalt, abbrechen
On Error Resume Next
If FileLen(Path) = 0 Then Exit Function
On Error GoTo 0

' Datei lesen
intFF = FreeFile()
Open Path For Binary As #intFF
ReadTxtFile = Space$(LOF(intFF))
Get #intFF, , ReadTxtFile
Close #intFF
End Function

' Sie benötigen einen Verweis auf die
' [Microsoft Forms 2.0 Objektlibrary]
' (Sollte Sie diese nicht so einfach finden, einfach eine Userform einfügen und dann wieder entfernen)

Private Sub ZwischenablageSchreiben(ByVal strText As String)
Dim objDataObject As DataObject

On Error Resume Next

Set objDataObject = New DataObject
objDataObject.SetText strText
objDataObject.PutInClipboard

Set objDataObject = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

xlph, 3. Mai 2016

#41
MARCCC

MarcCC

vielen Dank.*Smilie

MarcCC, 3. Mai 2016

#42
MARCCC

MarcCC

Exel Dateien (aus Unterordnern) zusammenfassen

\@DeBabba

Ich habe mir dein Tool noch einmal angesehen und bei mir mit eingebaut. Kannst du dort noch eine Prüfung einbauen, die vor der Namensvergabe des zu durchsuchenden Ordners kontrolliert, ob dieses Blatt nicht schon existiert, das heisst, das jemand das Tool schon einmal gestartet hat? Bei mir ist der Name variabel von Ordner zu Ordner, so das ich nicht mit z.B. "Neuer Ordner" arbeiten kann. Die Ordner heissen dann z.B. Montag, Dienstag... etc.
Die Sub könnte dann mit einer MsgBox abbrechen oder den Namen dann einfach erweitern Montag(1)...etc.

Wäre super, danke schon mal vorab.

MArc

MarcCC, 23. Mai 2016

#43
XLPH

xlph

Mit dem API-Filesearch dürfte es schneller gehen...

(Überarbeiteter Code von Nepumuk)

xlph, 24. Mai 2016

#44
MARCCC

MarcCC

funktioniert super, vielen Dank

MarcCC, 24. Mai 2016

#45

(Du musst angemeldet oder registriert sein, um eine Antwort erstellen zu können.)

Seite 3 von 4

Thema:

Exel Dateien (aus Unterordnern) zusammenfassen

Die Seite wird geladen...

Exel Dateien (aus Unterordnern) zusammenfassen - Similar Threads - Exel Dateien Unterordnern
Exel Farbige Zahlen addieren
in Microsoft Excel Hilfe
Exel Farbige Zahlen addieren: Hallo an alle, folgendes Problem...ich möchte rote und blaue Zahlen zusammen zählen. Das Problem ist, dass ich eine Summenspalte für vormittags und nachmittags habe. In der Tabelle befinden sich...
Exel Arbeitsblatt Formatierung nach Betriebssystemwechsel ändern
in Microsoft Excel Hilfe
Exel Arbeitsblatt Formatierung nach Betriebssystemwechsel ändern: Guten Tag zusammen, ich bin der Gahlen und würde mich sehr freuen wenn man mir hier bei einem Problem weiterhelfen könnte. Jüngst habe ich mich dazu entschieden das Betriebssystem von Windows auf...
aus verschiedenen xls dateien auslesen und in ein formular auflisten
in Microsoft Excel Hilfe
aus verschiedenen xls dateien auslesen und in ein formular auflisten: Hallo, ich hoff das mir jemand helfen kann... mein problemm: habe ca. 1200 xls dateien wo ich die adressdaten auslesen und in einer neuen datei (tabellenblatt) eintragen muss. die auszulesenden...
Exel datei nach Text und Zahlenwerten durchsuchen
in Microsoft Excel Hilfe
Exel datei nach Text und Zahlenwerten durchsuchen: EInen wunderschönen Sonntag Mittag ;) Meine Frage ist folgende: Ich möchte eine Exeldatei nach Text und Zahlenwerten durchsuchen lassen und dann eine Summe bilden. Das sieht dann...
Sicherung einer EXEL-Datei auf DVD ?
in Microsoft Excel Hilfe
Sicherung einer EXEL-Datei auf DVD ?: Hallo an alle Wissenden, ich bin sicherlich ein kleiner Fisch in Sachen PC-Anwendung, habe mich nun aber dennoch an das Schreiben einer EXEL-Datei getraut und diese ist mir sogar gelungen. Sie...
Exel Datei gelöscht. brauche dringend hilfe !!!
in Microsoft Excel Hilfe
Exel Datei gelöscht. brauche dringend hilfe !!!: Ich habe von einer Exel Datei eine Verknüpfung erstellt und in der Verknüpfung eine Änderung vorgenommen. Jetzt ist die " Hauptdatei weg. da sind aber wichtige sachen drin gewesen!!! Wer kann...
.xls datei lässt sich nihct öffnen/exel 03 stürtzt ab
in Microsoft Excel Hilfe
.xls datei lässt sich nihct öffnen/exel 03 stürtzt ab: Hi ich habe heute morgen über einen mac und exel eine datei bearbeitet.Beim öffne kam makros aktivieren was ich bestätit hatte.als ich die beabeitet hatte lud ich sie auf lo.net2 hoch und als ich...

Anmelden oder registrieren

Suche

Diese Seite verwendet Cookies, um Inhalte zu personalisieren, diese deiner Erfahrung anzupassen und dich nach der Registrierung angemeldet zu halten.
Auf dieser Website werden Cookies für die Zugriffsanalyse und Anzeigenmessung verwendet.
Wenn du dich weiterhin auf dieser Seite aufhältst, akzeptierst du unseren Einsatz von Cookies.

Akzeptieren Weitere Informationen...

Information ausblenden