AW: Inhaltsverzeichnis mit Link
03.11.2020 16:27:15
Nepumuk
Hallo Ulli,
so:
Public Sub Inhaltsverzeichnis()
Const COLUMN_NUMBER As Long = 2
Dim objFileSearch As clsFileSearch, objFileDialog As FileDialog
Dim objWorkbook As Workbook
Dim ialngIndex As Long, lngFileCount As Long
Dim strFolder As String
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 Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With
With Tabelle1
Call .Range(.Cells(4, 2), .Cells(.Rows.Count, 11)).Clear
End With
With Tabelle1
Call .Range(.Cells(4, COLUMN_NUMBER), Cells(.Rows.Count, COLUMN_NUMBER)).ClearContents
End With
Set objFileSearch = New clsFileSearch
With objFileSearch
.CaseSenstiv = False
.Extension = "*.xls*"
.FolderPath = strFolder
.SubFolders = True
.NewSearch = True
.SearchLike = "LT_*"
lngFileCount = .Execute(Sort_by_Name, Sort_Order_Ascending)
For ialngIndex = 1 To lngFileCount
With .Files(ialngIndex)
Set objWorkbook = Workbooks.Open(Filename:=.Path, UpdateLinks:=3, ReadOnly:=True)
Call Tabelle1.Hyperlinks.Add(Anchor:=Tabelle1.Cells(ialngIndex + 3, COLUMN_NUMBER), _
Address:=.Path, TextToDisplay:=.Filename)
With objWorkbook.Worksheets(1)
Tabelle1.Cells(ialngIndex + 3, 5).Value = .Cells(5, 2).Value
Tabelle1.Cells(ialngIndex + 3, 8).Value = .Cells(6, 4).Value
Tabelle1.Cells(ialngIndex + 3, 11).Value = .Cells(7, 4).Value
End With
With Tabelle1
With .Range(.Cells(ialngIndex + 3, 2), .Cells(ialngIndex + 3, 11))
Call .BorderAround(LineStyle:=xlContinuous, Weight:=xlThin)
With .Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
End With
End With
End With
Call objWorkbook.Close(SaveChanges:=False)
Set objWorkbook = Nothing
End With
Next
End With
Set objFileSearch = Nothing
With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With
End If
End Sub
Gruß
Nepumuk
