Onderstaande code zorgt ervoor dat bestanden uit een bepaalde directory en subdirectories opgehaald wordt en geplaatst wordt in kolom B.
Dat werkt prima. De bestanden worden echter op alfabetische volgorde geplaatst. Het laatst aangemaakt bestand wordt dus onderaan geplaatst. Ik wil echter graag een lijst die de laatst aangemaakte file dus bovenaan plaatst.
of alfabetische volgorde andersom (grootste getal bovenaan). heb echter geen idee waarin ik dat zoeken moet in onderstaande code.
Dat werkt prima. De bestanden worden echter op alfabetische volgorde geplaatst. Het laatst aangemaakt bestand wordt dus onderaan geplaatst. Ik wil echter graag een lijst die de laatst aangemaakte file dus bovenaan plaatst.
of alfabetische volgorde andersom (grootste getal bovenaan). heb echter geen idee waarin ik dat zoeken moet in onderstaande code.
Code:
Public RowIndex As Integer
Public iStartDepth As Integer
Public iMaxDepth As Integer
Sub Recurse()
Dim sDirname As String
Sheets(5).tbDirectory.Text = Range("factuur!T2")
sDirname = Sheets(5).tbDirectory.Text
If Right(sDirname, 1) = "\" Then sDirname = Left(sDirname, Len(sDirname) - 1)
Application.ScreenUpdating = False
'Read the level of start folder
iStartDepth = CharCount(CStr(sDirname), "\")
'Reset the formatting
Columns("B:B").Select
Selection.Font.Bold = False
Selection.Font.Bold = True
Cells.Select
Selection.ClearContents
Selection.Hyperlinks.Delete
Selection.Font.Underline = xlUnderlineStyleNone
Selection.Font.ColorIndex = 0
Selection.EntireRow.Hidden = False
Call UngroupRows
Range("a1").Select
RowIndex = 1
Call RecurseFolderList(sDirname & "\")
Call GroupRows
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "Lijst gemaakt van: " & RowIndex - 1 & " bestanden uit: " & iMaxDepth & " Map(pen)"
End
End Sub
Public Function RecurseFolderList(FolderName As String) _
As Boolean
On Error Resume Next
Dim fso, f, fc, fj, f1
Dim iNameStart As String
Dim iDepth As Integer
Set fso = CreateObject("Scripting.FileSystemObject")
If Err.Number > 0 Then
RecurseFolderList = False
Exit Function
End If
On Error GoTo 0
If fso.FolderExists(FolderName) Then
Set f = fso.GetFolder(FolderName)
Set fc = f.Subfolders
Set fj = f.Files
'For each subfolder in the Folder
For Each f1 In fc
'Do something with the Folder Name
'Range("Type").Cells(RowIndex, 1) = " "
iNameStart = InStrRev(f1, "\", -1, vbTextCompare)
iDepth = CharCount(CStr(f1), "\") - iStartDepth
If iDepth > iMaxDepth Then iMaxDepth = iDepth
Range("Type").Cells(RowIndex, iDepth) = Mid(f1, iNameStart + 1, Len(f1) - iNameStart)
RowIndex = RowIndex + 1
'Then recurse this function with the sub-folder to get any'
' sub-folders
RecurseFolderList (f1)
Next
'For each folder check for any files
For Each f1 In fj
'Range("Type").Cells(RowIndex, 1) = " "
iNameStart = InStrRev(f1, "\", -1, vbTextCompare)
iDepth = CharCount(CStr(f1), "\") - iStartDepth
If iDepth > iMaxDepth Then iMaxDepth = iDepth
Range("Type").Cells(RowIndex, iDepth).Select
Selection = Mid(f1, iNameStart + 1, Len(f1) - iNameStart)
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=CStr(f1)
RowIndex = RowIndex + 1
Next
Set f = Nothing
Set fc = Nothing
Set fj = Nothing
Set f1 = Nothing
Else
RecurseFolderList = False
End If
Set fso = Nothing
End Function
Public Function CharCount(OrigString As String, _
Chars As String, Optional CaseSensitive As Boolean = False) _
As Long
'**********************************************
'PURPOSE: Returns Number of occurrences of a character or
'or a character sequencence within a string
'PARAMETERS:
'OrigString: String to Search in
'Chars: Character(s) to search for
'CaseSensitive (Optional): Do a case sensitive search
'Defaults to false
'RETURNS:
'Number of Occurrences of Chars in OrigString
'EXAMPLES:
'Debug.Print CharCount("FreeVBCode.com", "E") -- returns 3
'Debug.Print CharCount("FreeVBCode.com", "E", True) -- returns 0
'Debug.Print CharCount("FreeVBCode.com", "co") -- returns 2
''**********************************************
Dim lLen As Long
Dim lCharLen As Long
Dim lAns As Long
Dim sInput As String
Dim sChar As String
Dim lCtr As Long
Dim lEndOfLoop As Long
Dim bytCompareType As Byte
sInput = OrigString
If sInput = "" Then Exit Function
lLen = Len(sInput)
lCharLen = Len(Chars)
lEndOfLoop = (lLen - lCharLen) + 1
bytCompareType = IIf(CaseSensitive, vbBinaryCompare, _
vbTextCompare)
For lCtr = 1 To lEndOfLoop
sChar = Mid(sInput, lCtr, lCharLen)
If StrComp(sChar, Chars, bytCompareType) = 0 Then _
lAns = lAns + 1
Next
CharCount = lAns
End Function
Sub UngroupRows()
On Error GoTo EndSub
For i = 1 To 50
Rows.Ungroup
Next
EndSub:
End Sub
Sub GroupRows()
Call UngroupRows
Dim iStart As Integer
Dim iEnd As Integer
Dim bGroup As Boolean
'RowIndex = 400
'iMaxDepth = 2
iStart = Range("Type").Row + 1
'Level 1 grouping (simple)
For i = 2 To RowIndex
If Range("Type").Cells(i, 1) <> Empty Or i = RowIndex Then
'End of group
iEnd = Range("Type").Cells(i, 1).Row - 1
Rows(iStart & ":" & iEnd).Group
iStart = iEnd + 2
End If
Next
'Deeper levels grouping
bGroup = False
For j = 2 To iMaxDepth 'Column
For i = 2 To RowIndex 'Row
'Find end of group (row with value on column or previous column
If bGroup = True Then
For x = j To 1 Step -1
If Range("Type").Cells(i, x) <> Empty Or i = RowIndex Then
'End of group
iEnd = Range("Type").Cells(i, x).Row - 1
Rows(iStart & ":" & iEnd).Group
bGroup = False
Exit For
End If
Next
End If
'Find start of group (corner)
If bGroup = False And Range("Type").Cells(i, j) <> Empty And Range("Type").Cells(i + 1, j + 1) <> Empty Then
iStart = Range("Type").Cells(i, j).Row + 1
bGroup = True
End If
Next
Next
End Sub
