Neuste Dateiversion öffnen bei vers. Dateinamen

Sub Open_workscope_files() Dim FileSystem As Object Dim HostFolder As String 'rootpath containing all DLH folders HostFolder = "\...\Desktop\Worksheets" Set FileSystem = CreateObject("Scripting.FileSystemObject") DoFolder FileSystem.GetFolder(HostFolder) End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'Code in einem allgemeinen Modul Option Explicit Private Zeile As Long, arrFiles() As String, intFile As Integer Sub Open_workscope_files() Dim FileSystem As Object Dim HostFolder As String Zeile = 1 intFile = 0 Erase arrFiles 'rootpath containing all DLH folders HostFolder = "\...\Desktop\Worksheets" HostFolder = "Y:\Test" Set FileSystem = CreateObject("Scripting.FileSystemObject") DoFolder FileSystem.GetFolder(HostFolder) If intFile > 0 Then For Zeile = 1 To intFile MsgBox arrFiles(2, Zeile) Cells(Zeile + 1, 1) = arrFiles(2, Zeile) Next End If End Sub Sub DoFolder(Folder) Dim SubFolder, strXlFile As String For Each SubFolder In Folder.SubFolders strXlFile = fncGetFileName(objFolder:=SubFolder) ' Zeile = Zeile + 1 'Testzeile ' ActiveSheet.Cells(Zeile, 1) = SubFolder.Path 'Testzeile ' ActiveSheet.Cells(Zeile, 2) = strXlFile 'Testzeile DoFolder SubFolder Next Dim file End Sub Function fncGetFileName(ByVal objFolder As Object) As String Dim bolFound As Boolean, file As Variant Dim iCount As Integer, iNumber As Integer Dim strExcelFile As String, strLatest As String iCount = -1 For Each file In objFolder.Files If Right(LCase(file.Name), 5) Like "*.xls*" Then strExcelFile = file.Name If IsNumeric(Left(strExcelFile, 1)) Then ' 1st, 2nd, 3rd, 5th, ... strExcelFile = Left(strExcelFile, 2) If IsNumeric(Right(strExcelFile, 1)) Then iNumber = Val(strExcelFile) Else iNumber = Val(Left(strExcelFile, 1)) End If iNumber = Val(strExcelFile) ElseIf InStr(1, strExcelFile, "issue") > 0 Then strExcelFile = Mid(strExcelFile, InStr(1, strExcelFile, "issue") + 5) strExcelFile = Trim(Left(strExcelFile, InStrRev(strExcelFile, ".") - 1)) iNumber = Val(strExcelFile) Else iNumber = 0 End If If iNumber > iCount Then If iCount = -1 Then intFile = intFile + 1 ReDim Preserve arrFiles(1 To 2, 1 To intFile) End If iCount = iNumber arrFiles(1, intFile) = file.Name arrFiles(2, intFile) = file.Path strLatest = file.Name End If End If Next fncGetFileName = strLatest End Function

Hallo JB,
schau dir bitte mal an ob das deinen Vorstellungen entspricht:

Sub Aktualisierung()
Dim sHostfolder As String   'Hauptordner
Dim fFolders() As String    'alle Unterordner
Dim fFiles()                'alle *xls-Files im aktiven Unterordner
Dim i As Long, j As Long    'Zähler
ReDim fFolders(0)
sHostfolder = "R:\Arbeitsordner\Tutorial_Excel\Tests\fFolders"
fFolders(0) = sHostfolder 'Falls im Hostfolder selber auch Dateien liegen können diesen  _
ebenfalls merken
GetFolders sHostfolder, fFolders 'hole alle Unterordner
For i = 0 To UBound(fFolders) 'für jeden Unterordner
ReDim fFiles(0)
fFiles(0) = Dir(fFolders(i) & "\*.txt")
Do Until fFiles(0) = ""     'bestimme "*.xls*"-Files im Ordner
ReDim Preserve fFiles(UBound(fFiles) + 1)
fFiles(UBound(fFiles)) = fFiles(0)
fFiles(0) = Dir
Loop
fFiles(0) = 0
For j = 1 To UBound(fFiles) 'aus allen "*.xls*"-Files die neueste bestimmen
If ExtractNumbers(CStr(fFiles(j))) > fFiles(0) Then _
fFiles(0) = ExtractNumbers(CStr(fFiles(j)))
Next j
RefreshFile (fFolders(i) & "\" & fFiles(0) & "*.txt") 'Aufruf des Files und  _
Kopiervorgang
Next i
End Sub

'Abwandlung aus diesem Post:  _
http://www.office-loesung.de/ftopic138569_0_0_asc.php
Private Sub GetFolders(ByVal sHostfolder As String, fFolders() As String)
Dim objFS As Object, objFolder As Object
Set objFS = CreateObject("Scripting.FilesystemObject")
Set objFolder = objFS.GetFolder(sHostfolder)
Tree objFolder, fFolders
Set objFolder = Nothing
Set objFS = Nothing
End Sub
Private Sub Tree(ByVal objFolder As Object, fFolders() As String)
Dim objSubFolder As Object
For Each objSubFolder In objFolder.subfolders
ReDim Preserve fFolders(UBound(fFolders) + 1)
fFolders(UBound(fFolders)) = objSubFolder.Path 'Subfolder merken
Tree objSubFolder, fFolders
Next
End Sub

Private Sub RefreshFile(ByVal wkbName As String)
Dim wkbFile As Workbook
Set wkbFile = Workbooks.Open(wkbName, ReadOnly:=True)
'...deine Kopierroutine ("Informationen einlesen")
With wkbFile
'wkbFile.Sheets("Tabelle1").Range("A1:A10").Copy _
Destination:=ThisWorkbook.Sheets("Tabelle1").Range("A1:A10") 'Beispielhaft
End With
wkbFile.Close
End Sub

Private Function ExtractNumbers(sFileName As String) As Long
Dim x As Long
If IsNumeric(Left(sFileName, 1)) Then 'beginnt mit Zahl
For x = Len(sFileName) To 1 Step -1
If IsNumeric(Left(sFileName, x)) Then Exit For
Next x
ExtractNumbers = Left(sFileName, x)
Else 'beginnt mit Text
End If
End Function

Die Funktion ExtractNumbers ist noch nicht gänzlich fertig, denn es werden nur deine Tabellen welche mit einer Zahl beginnen erkannt. Den zweiten Teil musst du noch einfügen ODER deine Namens-Struktur vereinheitlichen, was ja nicht immer möglich ist.
Aber ich denke dieser Teil hilft dir schonmal weiter.
lg Matthias

Private Function ExtractNumbers(sFileName As String) As Long Dim x As Long If IsNumeric(Left(sFileName, 1)) Then 'beginnt mit Zahl For x = Len(sFileName) To 1 Step -1 If IsNumeric(Left(sFileName, x)) Then Exit For Next x 'ExtractNumbers = Left(sFileName, x) ElseIf InStr(1, sFileName, "issue") > 0 Then 'beginnt mit Text x = InStr(1, sFileName, "issue") + 5 ExtractNumbers = Trim(Mid(sFileName, x, InStr(1, sFileName, ".xls*") - x)) End If End Function

Beliebteste Forumthreads (12 Monate)

Neuste Dateiversion öffnen bei vers. Dateinamen

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Neuste Dateiversion öffnen bei vers. Dateinamen

9 Beiträge zum Forumthread Beiträge zu diesem Forumthread

299 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

9
Beiträge zum Forumthread

Beiträge zu diesem Forumthread