Files - Info - Link - Date!

In the following code information about files is spent. Over additional columns the date of preparation is sorted. The files at the end of the article are Excelfiles of the version 2003 and 2007. The following code belonged in "Module1, UserForm1, Module2, UserForm2".


Im folgenden Code werden Informationen über Dateien ausgegeben. Über zusätzliche Hilfsspalten wird das Erstellungsdatum sortiert. Die Dateien am Ende des Artikels sind Exceldateien der Version 2003 und 2007. Der folgende Code gehört in "Modul1, UserForm1, Modul2, UserForm2".


Option Explicit
Private strList() As String
Private intSheet As Integer
Private strDate() As String
Private strDir() As String
Private lngCount As Long
Public Sub Test()
Dim strTMP As String
On Error GoTo Fin
intSheet = 1 ' adapt (1 = sheet index)
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*", True ' adapt (False = without Subfolder)
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(intSheet)
.Cells.Clear
.Range(.Cells(1, 1), .Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strDir)
.Range(.Cells(1, 2), .Cells(lngCount, 2)) = _
WorksheetFunction.Transpose(strList)
.Range(.Cells(1, 3), .Cells(lngCount, 3)) = _
WorksheetFunction.Transpose(strDate)
.Range(.Cells(1, 3), .Cells(lngCount, 3)).NumberFormat = "dd.mm.yyyy"
.Columns(3).TextToColumns Destination:=.Range("D1"), _
DataType:=xlDelimited, Other:=True, OtherChar:=".", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
.Columns("A:F").AutoFit
End With
Call Make_Link
Select Case MsgBox("Sort? YES ascending, NO descending, or Cancel.", _
vbYesNoCancel Or vbQuestion Or vbDefaultButton1, "Sort")
Case vbYes
UserForm1.Show
ThisWorkbook.Worksheets(intSheet).UsedRange.Sort _
Key1:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm1.Label1.Tag)), _
Order1:=xlAscending, _
Key2:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm1.Label1.Caption)), _
Order2:=xlAscending, _
Header:=xlNo
Case vbNo
UserForm1.Show
ThisWorkbook.Worksheets(intSheet).UsedRange.Sort _
Key1:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm1.Label1.Tag)), _
Order1:=xlDescending, _
Key2:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm1.Label1.Caption)), _
Order2:=xlDescending, _
Header:=xlNo
Case vbCancel
End Select
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String, _
Optional blnSubFolder As Boolean = False)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
Redim Preserve strDir(lngCount)
Redim Preserve strDate(lngCount)
strDir(lngCount) = strFolder & "\"
strList(lngCount) = objFile.Name
strDate(lngCount) = Format(objFile.DateCreated, "dd.mm.yyyy")
lngCount = lngCount + 1
End If
Next objFile
If blnSubFolder = True Then
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName, True
Next objFolder
End If
End Sub
Private Sub Make_Link()
Dim lngRow As Long
With ThisWorkbook.Worksheets(intSheet)
lngRow = .Range("B" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1) & .Cells(lngRow, 2)
Next lngRow
End With
End Sub


Option Explicit
Private Sub OptionButton1_Click()
Label1.Tag = 5
Label1.Caption = 4
Me.Hide
End Sub
Private Sub OptionButton2_Click()
Label1.Tag = 4
Label1.Caption = 5
Me.Hide
End Sub
Private Sub OptionButton3_Click()
Label1.Tag = 6
Label1.Caption = 5
Me.Hide
End Sub
Private Sub UserForm_Activate()
OptionButton1.Value = False
OptionButton2.Value = False
OptionButton3.Value = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub


Option Explicit
Private strList() As String
Private intSheet As Integer
Private lngCount As Long
Public Sub Test_1()
Dim strTMP As String
On Error GoTo Fin
intSheet = 1 ' adapt (1 = sheet index)
lngCount = 0
strTMP = GetFolder()
If strTMP = "" Or Left(strTMP, 1) = ":" Then Exit Sub
SearchFiles strTMP, "*.*", True ' adapt (False = without Subfolder)
If lngCount = 0 Then
MsgBox "No file found"
Exit Sub
End If
With ThisWorkbook.Worksheets(intSheet)
.Cells.Clear
.Range(.Cells(1, 1), .Cells(lngCount, 1)) = _
WorksheetFunction.Transpose(strList)
.Columns(1).TextToColumns Destination:=.Range("A1"), _
DataType:=xlDelimited, Other:=True, OtherChar:="|", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), _
Array(4, 1), Array(5, 1))
.Range(.Cells(1, 5), .Cells(lngCount, 5)).NumberFormat = "dd.mm.yyyy"
.Columns(5).TextToColumns Destination:=.Range("F1"), _
DataType:=xlDelimited, Other:=True, OtherChar:=".", _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1))
.Columns("A:H").AutoFit
End With
Call Make_Link
Select Case MsgBox("Sort? YES ascending, NO descending, or Cancel.", _
vbYesNoCancel Or vbQuestion Or vbDefaultButton1, "Sort")
Case vbYes
UserForm2.Show
ThisWorkbook.Worksheets(intSheet).UsedRange.Sort _
Key1:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm2.Label1.Tag)), _
Order1:=xlAscending, _
Key2:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm2.Label1.Caption)), _
Order2:=xlAscending, _
Header:=xlNo
Case vbNo
UserForm2.Show
ThisWorkbook.Worksheets(intSheet).UsedRange.Sort _
Key1:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm2.Label1.Tag)), _
Order1:=xlDescending, _
Key2:=ThisWorkbook.Worksheets(intSheet).Cells _
(1, CInt(UserForm2.Label1.Caption)), _
Order2:=xlDescending, _
Header:=xlNo
Case vbCancel
End Select
Fin:
If Err.Number <> 0 Then MsgBox Err.Number & " " & Err.Description
End Sub
Private Function GetFolder() As String
Dim varFolder As Variant
Dim objShell As Object
Dim strPath As String
Set objShell = CreateObject("Shell.Application")
Set varFolder = objShell.BrowseForFolder(0, "Folder", &H4000, 17)
If varFolder Is Nothing Then
Set varFolder = Nothing
Set objShell = Nothing
Exit Function
End If
GetFolder = varFolder.Self.Path
Set varFolder = Nothing
Set objShell = Nothing
End Function
Private Sub SearchFiles(strFolder As String, strFileName As String, _
Optional blnSubFolder As Boolean = False)
Dim objFolder As Object
Dim objFile As Object
Dim objFSO As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
For Each objFile In objFSO.GetFolder(strFolder).Files
If objFile.Name Like strFileName Then
Redim Preserve strList(lngCount)
strList(lngCount) = strFolder & "\" & _
"|" & objFile.Name & _
"|" & objFile.Type & _
"|" & objFile.Size & _
"|" & Format(objFile.DateCreated, "dd.mm.yyyy")
lngCount = lngCount + 1
End If
Next objFile
If blnSubFolder = True Then
For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
SearchFiles strFolder & "\" & objFolder.Name, strFileName, True
Next objFolder
End If
End Sub
Public Sub Make_Link()
Dim lngRow As Long
With ThisWorkbook.Worksheets(intSheet)
lngRow = .Range("B" & .Rows.Count).End(xlUp).Row
For lngRow = 1 To lngRow
.Hyperlinks.Add Anchor:=.Cells(lngRow, 2), _
Address:=.Cells(lngRow, 1) & .Cells(lngRow, 2)
Next lngRow
End With
End Sub


Option Explicit
Private Sub OptionButton1_Click()
Label1.Tag = 7
Label1.Caption = 6
Me.Hide
End Sub
Private Sub OptionButton2_Click()
Label1.Tag = 6
Label1.Caption = 7
Me.Hide
End Sub
Private Sub OptionButton3_Click()
Label1.Tag = 8
Label1.Caption = 7
Me.Hide
End Sub
Private Sub UserForm_Activate()
OptionButton1.Value = False
OptionButton2.Value = False
OptionButton3.Value = False
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub


Sample 2003

Sample 2007

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...