Office: neueste Datei in Unterordnern suchen und importieren

Mazz78 · 3. April 2016

Hallo zusammen,

ich habe mittlerweile (gefühlt) ganz Google durchsucht.
Dabei hab ich auch einige verschiedene Skripte gefunden.
Leider sind meine VBA-Kenntnisse nicht gut genug um daraus EIN funktionierendes Skript daraus zu machen.
Dashalb wende ich mich jetzt an euch... *biggrin.gif*

Das Skript soll folgendes machen:
1. in allen vorhandenen Unterordnern (des angegebenen Pfades)
2. die neueste Datei mit der Endung csv suchen (nach Erstelldatum)
3. diese Datei öffnen und den Inhalt importieren
4. die csv-Datei wird zu diesem Zeitpunkt von einem anderen Skript mit weiteren Daten gefüttert -> öffnen im read-only-Modus ?!

Ich habe folgendes Skript gefunden das den ersten Punkt perfekt macht.
Aber eben nur den ersten.
Könnte mir da jemand helfen und das erweitern ?*depressed

Code:

Sub JuengsteDatei()
Const strVerz As String = "C:\001_Test\Test\Txt\"
Const strExt As String = ".alp"
Dim strDatei As String, strScratch As String

strScratch = Dir(strVerz & "*" & strExt)
strDatei = strScratch
Do While strScratch ""
If FileDateTime(strVerz & strDatei) < FileDateTime(strVerz & strScratch) Then strDatei = strScratch
strScratch = Dir()
Loop
If strDatei "" Then
Workbooks.Open strVerz & strDatei
Else
MsgBox "keine Datei gefunden"
End If
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Grüße
Sven

:)

ASE · 5. April 2016

Hallo Sven,

Das Skript soll folgendes machen:
1. in allen vorhandenen Unterordnern (des angegebenen Pfades)
2. die neueste Datei mit der Endung csv suchen (nach Erstelldatum)
3. diese Datei öffnen und den Inhalt importieren
4. die csv-Datei wird zu diesem Zeitpunkt von einem anderen Skript mit weiteren Daten gefüttert -> öffnen im read-only-Modus ?!
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

zu 1. der Skript den Du angegeben hast sucht und findet nur in einem Verzeichnis und nicht in den Unterordnern.
zu 3. wohin importieren in irgend eine Tabelle?
zu 4. kann problematisch sein; Ich kann mir nicht vorstellen warum das zwingend erorderlich sein soll.
Es wäre besser Du lädst Demos hoch, dann kann man sehen was passieren soll.

xlph · 5. April 2016

Eine mögliche Variante...

Code:

Option Explicit

Public Sub CSV_Import()
Dim strPath As String
Dim astrPath() As String
Dim i As Long

Dim strText As String

strPath = "E:\Test"

astrPath() = SubfolderFiles(strPath, "*.csv")

If (Not astrPath()) -1 Then
For i = LBound(astrPath) To UBound(astrPath)
strText = strText & ReadTxtFile(astrPath(i))
Next

Call TextPutInClipboard(strText)

With Tabelle1
.UsedRange.ClearContents
.Paste .Range("A1")
End With
Else
MsgBox "Keine .csv gefunden!"
End If

End Sub

Public Function SubfolderFiles( _
ByVal strPath As String, _
Optional ByVal strFileSuffix As String = "*.*") As String()

Dim strFoldername As String
Dim strFilename As String

Dim astrPathSubfolder() As String
Dim astrPathSubfolderfile() As String
Dim i As Long, j As Long

If Right$(strPath, 1) "\" Then strPath = strPath & "\"

strFoldername = Dir(strPath, vbDirectory)

Do Until strFoldername = vbNullString

If strFoldername "." And strFoldername ".." Then
If GetAttr(strPath & strFoldername) = vbDirectory Then
ReDim Preserve astrPathSubfolder(0 To i)
astrPathSubfolder(i) = strPath & strFoldername
i = i + 1
End If
End If

strFoldername = Dir()
Loop

If i = 0 Then
MsgBox "Keine Unterordner gefunden!": Exit Function
End If

For i = LBound(astrPathSubfolder) To UBound(astrPathSubfolder)
strFilename = YoungestFile(astrPathSubfolder(i), strFileSuffix)
If strFilename vbNullString Then
ReDim Preserve astrPathSubfolderfile(0 To j)
astrPathSubfolderfile(j) = astrPathSubfolder(i) & "\" & strFilename
j = j + 1
End If
Next

SubfolderFiles = astrPathSubfolderfile()

End Function

Function YoungestFile( _
ByVal strPath As String, _
Optional ByVal strFileSuffix As String = "*.*") As String

Dim strFilename As String
Dim strFilenameY As String

If Right$(strPath, 1) "\" Then strPath = strPath & "\"

strFilename = Dir(strPath & strFileSuffix)

strFilenameY = strFilename

Do Until strFilename = vbNullString

If FileDateTime(strPath & strFilename) > _
FileDateTime(strPath & strFilenameY) Then
strFilenameY = strFilename
End If

strFilename = Dir()
Loop

YoungestFile = strFilenameY

End Function

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 TextPutInClipboard(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.

Mazz78 · 6. April 2016

Hi xlph,

zuerst mal vielen Dank für deine Arbeit. Fast perfekt...*cool.gif*

Leider importiert das Skript nicht die zuletzt erstellte csv, sondern die csv aus dem alphabetisch nächsten Ordner.
z.B:
Als Ordnerpfad habe ich C:\Daten\...
Dieser hat die Unterordner AA, BB, und CC. Obwohl die csv des Ordners CC als letztes angelegt wurde, importiert er die csv aus AA.

Grüße Sven

_anton_ · 7. April 2016

Hallo Sven,

noch eine Variante, die aktuellste Datei zu finden:
Code:

Option Explicit

Private Declare Function OemToCharA Lib "user32.dll" _
(ByVal lpszSrc As String, ByVal lpszDst As String) As Long

Public Function ASCIItoANSI(ByVal Text As String) As String
Call OemToCharA(Text, Text)
ASCIItoANSI = Text
End Function

Sub aktuellste_finden()
Dim objShell As Object, objExec As Object, fso As Object, rsDataList As Object
Dim vntRet As Variant, strFolder As String, strTMP As String, datei
strFolder = "F:\2005" 'anpassen
Set objShell = CreateObject("WScript.Shell")
ChDrive Left(strFolder, 1)
ChDir strFolder
Set objExec = objShell.Exec("cmd /c dir /s /b /a:-d *.csv*")
strTMP = ASCIItoANSI(objExec.StdOut.ReadAll)
vntRet = Split(strTMP, vbCrLf)
If UBound(vntRet) > 0 Then
Set fso = CreateObject("Scripting.FileSystemObject")
Set rsDataList = CreateObject("ADODB.Recordset")
With rsDataList
.Fields.Append "fldDatei", 200, 256
.Fields.Append "fldDatum", 135, 25
.Open
For Each datei In vntRet
If datei "" Then
.AddNew
rsDataList("fldDatei") = datei
rsDataList("fldDatum") = fso.GetFile(datei).DateLastModified
.Update
End If
Next
.Sort = "fldDatum"
.MoveLast
MsgBox "Aktuellste Datei: " & .Fields.Item("fldDatei") & vbCr & _
"letzte Änderung: " & .Fields.Item("fldDatum")
End With
Else
MsgBox "keine Datei gefunden"
End If
Set fso = Nothing
Set rsDataList = Nothing
Set objExec = Nothing
Set objShell = Nothing
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

mfg Anton

xlph · 7. April 2016

Leider importiert das Skript nicht die zuletzt erstellte csv, sondern die csv aus dem alphabetisch nächsten Ordner.
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Kommt auf die Sichtweise an.

Ich habe dich wie folg verstanden:
In Unterordnern (nur 1. Ebene) befinden sich Dateien, aus denen die jeweils Jüngste ermittelt werden soll und deren Inhalt gesammelt in ein Blatt eingetragen wird.

Das macht mein Code.

Oder meintest du dass jeweils nur 1 Datei in einem Unterordner vorliegt und aus diesen die jüngste ermittelt werden soll?

EarlFred · 12. Januar 2021

Hallo zusammen,

einfach nur, damit noch ein Code da ist:
Code:

Option Explicit

Dim arrAusgabe As Object

Private Sub Dateilister_Shell()

On Error GoTo ErrExit

Set arrAusgabe = CreateObject("System.Collections.Arraylist")
Dim shShell As Object 'Shell32.Shell
Dim shFolder As Object 'Shell32.Folder
Dim fVar As Variant

Set shShell = CreateObject("Shell.Application")
Set shFolder = shShell.Namespace("C:\temp")

listFiles shFolder

If arrAusgabe.Count Then
arrAusgabe.Sort
fVar = arrAusgabe.ToArray
fVar = fVar(UBound(fVar))
MsgBox "Datum: " & Format(Split(fVar, "#")(0), "DD.MM.YYYY hh:mm:ss") & vbLf & _
"Datei: " & Split(fVar, "#")(1)
Else
MsgBox "Keine CSV-Dateien gefunden!", vbCritical + vbOKOnly, "Keine CSV"
End If
GoTo aufräumen

ErrExit:
If Err Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description & vbLf & "Anzahl gefundene Dateien: " & arrAusgabe.Count

aufräumen:
Set shFolder = Nothing
Set shShell = Nothing

End Sub

Private Sub listFiles(ByRef shFolder As Object)

Dim shFItemp As Object 'Shell32.FolderItem

On Error Resume Next

For Each shFItemp In shFolder.Items
If shFItemp.IsFolder And LCase$(Right$(shFItemp.Name, 4)) ".zip" Then
listFiles shFItemp.GetFolder
ElseIf (shFItemp.Name Like "*.csv") Then
arrAusgabe.Add CDbl(shFItemp.ModifyDate) & "#" & shFItemp.Path & "\" & shFItemp.Name
End If
Next shFItemp
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

von _anton_

noch eine Variante
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

großartig!

Grüße
EarlFred

Mazz78 · 7. April 2016

Hallo zusammen,

das war so gedacht...
Auch wenn der Unterordner_Mrz der letzte/jüngste ist, gibt es mit der csv_Apr trotzdem noch eine jüngere Datei. Diese soll er suchen und dann importieren.

Überordner_2016

Unterordner_Jan
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Jan_01
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Jan_02
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Apr_01
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Unterordner_Feb
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Feb_01
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Feb_02
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Feb_03
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Unterordner_Mrz
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

csv_Mrz_01
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Ich hab eine Lösung. Das folgende Skript funktioniert. *dance
Zu der "Sauberkeit" / Performance, kann ich leider nichts sagen. Vielleicht gibt es da Potential

Danke an dieser Stelle an alle *top

Code:

Option Explicit

Public Sub CSV_Import()
Dim strPath As String
Dim astrPath() As String
Dim i As Long

Dim strText As String

strPath = "C:\Users\uidj7523\Desktop\testing\common\tests\monitoring\Daten"

astrPath() = SubfolderFiles(strPath, "*.csv")

If (Not astrPath()) -1 Then
'For i = LBound(astrPath) To UBound(astrPath)
strText = strText & ReadTxtFile(astrPath(UBound(astrPath)))
'Next

Call TextPutInClipboard(strText)

With Tabelle1
.UsedRange.ClearContents
.Paste .Range("A1")
End With
Else
MsgBox "Keine .csv gefunden!"
End If

End Sub

Public Function SubfolderFiles( _
ByVal strPath As String, _
Optional ByVal strFileSuffix As String = "*.*") As String()

Dim strFoldername As String
Dim strFilename As String
Dim fDateTime As Date

Dim astrPathSubfolder() As String
Dim astrPathSubfolderfile() As String
Dim SortFiles() As String
Dim NewSort() As String

Dim i As Long, j As Long, k As Long

If Right$(strPath, 1) "\" Then strPath = strPath & "\"

strFoldername = Dir(strPath, vbDirectory)

Do Until strFoldername = vbNullString

If strFoldername "." And strFoldername ".." Then
If GetAttr(strPath & strFoldername) = vbDirectory Then
ReDim Preserve astrPathSubfolder(0 To i)
astrPathSubfolder(i) = strPath & strFoldername
i = i + 1
End If
End If

strFoldername = Dir()
Loop

If i = 0 Then
MsgBox "Keine Unterordner gefunden!": Exit Function
End If

For i = LBound(astrPathSubfolder) To UBound(astrPathSubfolder)
strFilename = YoungestFile(astrPathSubfolder(i), fDateTime, strFileSuffix)
If strFilename vbNullString Then
ReDim Preserve astrPathSubfolderfile(0 To j)
astrPathSubfolderfile(j) = astrPathSubfolder(i) & "\" & strFilename & " [" & fDateTime & "]"
j = j + 1
End If
Next

ReDim SortFiles(UBound(astrPathSubfolderfile))
ReDim NewSort(UBound(astrPathSubfolderfile))

Dim sDate1 As String

For i = 0 To UBound(astrPathSubfolderfile)
sDate1 = Mid(astrPathSubfolderfile(i), InStr(1, astrPathSubfolderfile(i), "["))
sDate1 = Replace(sDate1, "]", "")
sDate1 = Replace(sDate1, "[", "")
SortFiles(i) = sDate1
Next i

SelectionSort SortFiles

For j = 0 To UBound(SortFiles)
For i = 0 To UBound(astrPathSubfolderfile)

If InStr(1, astrPathSubfolderfile(i), SortFiles(j)) Then
NewSort(j) = Left(astrPathSubfolderfile(i), InStr(1, astrPathSubfolderfile(i), "[") - 1)
End If

Next i
Next j

SubfolderFiles = NewSort()

End Function

Function SelectionSort(TempArray As Variant)
Dim MaxVal As Variant
Dim MaxIndex As Integer
Dim i, j As Integer

' Step through the elements in the array starting with the
' last element in the array.
For i = UBound(TempArray) To 1 Step -1

' Set MaxVal to the element in the array and save the
' index of this element as MaxIndex.
MaxVal = TempArray(i)
MaxIndex = i

' Loop through the remaining elements to see if any is
' larger than MaxVal. If it is then set this element
' to be the new MaxVal.
For j = 0 To i
If TempArray(j) > MaxVal Then
MaxVal = TempArray(j)
MaxIndex = j
End If
Next j

' If the index of the largest element is not i, then
' exchange this element with element i.
If MaxIndex < i Then
TempArray(MaxIndex) = TempArray(i)
TempArray(i) = MaxVal
End If
Next i

End Function

Function YoungestFile( _
ByVal strPath As String, _
ByRef fDateTime As Date, _
Optional ByVal strFileSuffix As String = "*.*") As String
Dim sd As String

Dim strFilename As String
Dim strFilenameY As String

If Right$(strPath, 1) "\" Then strPath = strPath & "\"

strFilename = Dir(strPath & strFileSuffix)

strFilenameY = strFilename

Do Until strFilename = vbNullString

If FileDateTime(strPath & strFilename) > _
FileDateTime(strPath & strFilenameY) Then
strFilenameY = strFilename
End If

strFilename = Dir()
Loop

fDateTime = FileDateTime(strPath & strFilenameY)
YoungestFile = strFilenameY

End Function

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 TextPutInClipboard(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.

Office: neueste Datei in Unterordnern suchen und importieren

neueste Datei in Unterordnern suchen und importieren

neueste Datei in Unterordnern suchen und importieren

neueste Datei in Unterordnern suchen und importieren

neueste Datei in Unterordnern suchen und importieren

neueste Datei in Unterordnern suchen und importieren - Similar Threads - neueste Datei Unterordnern

Aus Access mehrere Excel-Tabellen in neue Datei speichern

Zeilen aus mehreren Dateien in neue Datei wenn...

einzelne Spalten in neue Dateien kopieren

Makro "Datei - Neu" Ansicht als Liste

VBA verschiedene definierte "nicht leere" Bereiche aus Datei kopieren in neue Datei

Makros für die neueste Datei in Unterordner ausführen

Ordner mit allen Unterordnern und Dateien in neuen Ordner kopieren