AW: warum nicht eine einfache Formel ...
05.03.2021 19:20:38
Nepumuk
Hallo Ulli,
ich hab dir noch die Sortierung eingebaut:
Public Sub Aktualisieren()
Const COLUMN_NUMBER As Long = 3
Dim objFileSearch As clsFileSearch, objFileDialog As FileDialog
Dim objWorkbook As Workbook
Dim ialngIndex As Long, lngFileCount As Long, lngRow As Long
Dim strFolder As String
Dim dtmDateFrom As Date, dtmDateTo As Date
Dim blnAbort As Boolean
Set objFileDialog = Application.FileDialog(fileDialogType:=msoFileDialogFolderPicker)
With objFileDialog
.AllowMultiSelect = False
.ButtonName = "Auswählen"
.Title = "Ordner auswählen"
.InitialFileName = ThisWorkbook.Path & "\"
If .Show Then strFolder = .SelectedItems(1)
End With
Set objFileDialog = Nothing
If strFolder <> vbNullString Then
With UserForm1
Call .Show
dtmDateFrom = .DateFrom
dtmDateTo = .DateTo
blnAbort = .Abort
End With
Call Unload(UserForm1)
If Not blnAbort Then
With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
With Tabelle1
Call .Range(.Cells(7, 1), .Cells(.Rows.Count, 15)).ClearContents
Range(.Cells(7, 1), .Cells(.Rows.Count, 15)).Borders.LineStyle = xlLineStyleNone
End With
With Tabelle1
Call .Range(.Cells(7, COLUMN_NUMBER), Cells(.Rows.Count, COLUMN_NUMBER)).ClearContents
End With
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xlsm"
.FolderPath = strFolder
.SubFolders = True
.NewSearch = True
.SearchLike = "UA_*"
lngFileCount = .Execute(Sort_by_Name, Sort_Order_Ascending)
lngRow = 6
For ialngIndex = 1 To lngFileCount
With .Files(ialngIndex)
'Prüfen ob letzter Zugriff größer gleich dem 1.1. des laufenden Jahres
If .LastModify >= dtmDateFrom Then
Set objWorkbook = Workbooks.Open(Filename:=.Path, UpdateLinks:=3, ReadOnly:=True)
'Prüfen ob Datum größer gleich dem 1.1. des laufenden Jahres
If objWorkbook.Worksheets(1).Range("Datum").Value >= dtmDateFrom And _
objWorkbook.Worksheets(1).Range("Datum").Value <= dtmDateTo Then
lngRow = lngRow + 1
Call Tabelle1.Hyperlinks.Add(Anchor:=Tabelle1.Cells(lngRow, _
COLUMN_NUMBER), Address:=.Path, TextToDisplay:=.Filename)
With objWorkbook.Worksheets(1)
'Tabelle1.Cells(lngRow, 1).Value = .Cells(1, 8).Value
Tabelle1.Cells(lngRow, 2).Value = .Range("Datum").Value
Tabelle1.Cells(lngRow, 4).Value = .Range("Nachname").Value
Tabelle1.Cells(lngRow, 5).Value = .Range("Vorname").Value
Tabelle1.Cells(lngRow, 6).Value = .Range("NL").Value
Tabelle1.Cells(lngRow, 7).Value = .Range("UO").Value
Tabelle1.Cells(lngRow, 8).Value = .Range("Tä").Value
Tabelle1.Cells(lngRow, 9).Value = .Range("Ar").Value
Tabelle1.Cells(lngRow, 10).Value = .Range("Un").Value
Tabelle1.Cells(lngRow, 11).Value = .Range("V").Value
Tabelle1.Cells(lngRow, 12).Value = .Range("KP").Value
Tabelle1.Cells(lngRow, 13).Value = .Range("MP").Value
Tabelle1.Cells(lngRow, 15).Value = .Range("GS").Value
'Tabelle1.Cells(lngRow, 14).Value = .Range("").Value
End With
With Tabelle1
With .Range(.Cells(lngRow, 1), .Cells(lngRow, 15))
Call .BorderAround(LineStyle:=xlContinuous, Weight:=xlThin)
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End With
End If
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
End If
End With
Next
End With
Set objFileSearch = Nothing
'Sortieren nach Datum
Call Range(Cells(6, 2), Cells(Rows.Count, 15)).Sort(Key1:=Cells(6, 2), Header:=xlYes)
Cells(7, 1).Value = 1 ' Fortlaufende Nummer
Range(Cells(7, 1), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 1)).DataSeries
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End If
End Sub
Gruß
Nepumuk