Projektverzeichnis anlegen

Hallo !
ich würde gerne mit excel folgendes erreichen:
ich bearbeite mehrere Projekte und jedes Projekt hat zunächst
einen eigenen Ordner z B.:
Projekt 1, Projekt 2, Projekt 3 die im gleichen Verzeichnis stehen.
jeder dieser Ordner enthält Unterordner z.B Angebote, Rechnungen,
Kalkulation, Mahnungen mit den jeweiligen Exceldateien.
Nun zu meiner Frage:
Kann man das Verzeichnis der Projekte in eine Tabelle auslesen
lassen wobei der Name des Projektes und des jeweiligen Unterordners in der Tabelle erscheint und die dazugehörigen Exceldateien
untereinander als Link angezeigt werden.
Optimal wäre, wenn für jedes Projekt in dem Verzeichnis automatisch
ein neues Arbeitsblatt mit dem
Projektnamen angelegt würde in welches die Dateien ausgelesen werden.
Ich weis meine Frage ist umfangreich aber ich verliere etwas die
Übersicht bei meinen vielen Projekten und Ihr würdet mir sehr helfen.
Gruß Nicole

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Dim wksStart As Worksheet, wksInhalt As Worksheet, vntFiles(), lngFiles As Long Public Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As Long End Type Declare Function SHGetPathFromIDList Lib "shell32.dll" _ Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _ ByVal pszPath As String) As Long Declare Function SHBrowseForFolder Lib "shell32.dll" _ Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long Function GetDirectory(Optional Msg) As String Dim bInfo As BROWSEINFO Dim Path As String Dim R As Long, x As Long, pos As Integer bInfo.pidlRoot = 0& If IsMissing(Msg) Then bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus." Else bInfo.lpszTitle = Msg End If bInfo.ulFlags = &H1 x = SHBrowseForFolder(bInfo) Path = Space$(512) R = SHGetPathFromIDList(ByVal x, ByVal Path) If R Then pos = InStr(Path, Chr$(0)) GetDirectory = Left(Path, pos - 1) Else GetDirectory = "" End If End Function Sub prcFolders() Dim FSO As Object, oFolder As Object Dim strFolder As String Application.ScreenUpdating = False Set wksStart = ThisWorkbook.Sheets("Start") Set wksInhalt = ThisWorkbook.Sheets("Inhalt") Set FSO = CreateObject("Scripting.FileSystemObject") strFolder = wksStart.Cells(1, 2) If strFolder = "" Then strFolder = GetDirectory Set oFolder = FSO.getfolder(strFolder) lngFiles = 1 With wksInhalt .Range("A:C").ClearContents .Cells(1, 1) = "Pfad" .Cells(1, 2) = "Dateiname" .Range(.Cells(1, 1), .Cells(1, 3)).Font.Bold = True End With prcFiles oFolder prcSubFolders oFolder With wksInhalt .Range(.Cells(2, 1), .Cells(lngFiles, 2)) = WorksheetFunction.Transpose(vntFiles) .Activate End With Application.ScreenUpdating = True End Sub Sub prcSubFolders(oFolder) Dim oSubFolder As Object For Each oSubFolder In oFolder.subfolders prcFiles oSubFolder prcSubFolders oSubFolder Next End Sub Sub prcFiles(oFolder) Dim oFile As Object For Each oFile In oFolder.Files ReDim Preserve vntFiles(1 To 2, 1 To lngFiles) vntFiles(1, lngFiles) = oFolder.Path vntFiles(2, lngFiles) = "=hyperlink(""" & oFile.Path & """;""" & oFile.Name & """)" lngFiles = lngFiles + 1 Next End Sub Gruß <b>Lesen gefährdet die Dummheit</b>

Hallo Nicole!
Probier mal diesen.

' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub ListAllFilesAndFolders()
Dim objFSO As Object, objFo As Object, objFu As Object, objFUu As Object, objF As Object
Dim strStartFolder As String, strSheetName As String
Dim objSh As Worksheet
Dim lngR As Long, intC As Integer

On Error GoTo ErrExit

GetMoreSpeed

strStartFolder = "F:\Office"

Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFo = objFSO.GetFolder(strStartFolder)

For Each objFu In objFo.subfolders
  intC = 1
  lngR = 1
  strSheetName = CheckSheetName(objFu.Name)
  With ThisWorkbook
    If SheetExist(strSheetName) Then
      Set objSh = .Sheets(strSheetName)
      objSh.Cells.Clear
    Else
      Set objSh = .Worksheets.Add(after:=.Sheets(.Sheets.Count))
      objSh.Name = strSheetName
    End If
  End With

  With objSh
    .Cells(lngR, intC) = objFu.Name
    .Hyperlinks.Add anchor:=.Cells(lngR, intC), Address:=objFu
    For Each objF In objFu.Files
      lngR = lngR + 1
      .Cells(lngR, intC) = objF.Name
      .Hyperlinks.Add anchor:=.Cells(lngR, intC), Address:=objF
    Next
    For Each objFUu In objFu.subfolders
      lngR = 1
      intC = intC + 1
      .Cells(lngR, intC) = objFUu.Name
      .Hyperlinks.Add anchor:=.Cells(lngR, intC), Address:=objFUu
      For Each objF In objFUu.Files
        lngR = lngR + 1
        .Cells(lngR, intC) = objF.Name
        .Hyperlinks.Add anchor:=.Cells(lngR, intC), Address:=objF
      Next
    Next
    .Rows(1).Font.Bold = True
    .Rows(1).Font.ColorIndex = 3
    .Columns.AutoFit
  End With
Next

ErrExit:

GetMoreSpeed 0

Set objFSO = Nothing
Set objFo = Nothing
Set objSh = Nothing

End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo ERRORHANDLER
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
  If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
ERRORHANDLER:
SheetExist = False
End Function

Private Function CheckSheetName(strName As String) As String
Dim notAllowed As Variant
Dim n As Integer
'Im Tabellennamen nicht zulässige Zeichen
notAllowed = Array(":", "\", "/", "?", "*", "[", "]")

'Prüfen ob unerlaubte Zeichen vorhanden
For n = 0 To UBound(notAllowed)
  strName = Replace(strName, notAllowed(n), "_")
Next

CheckSheetName = Left(strName, 31)

End Function

Sub GetMoreSpeed(Optional ByVal Modus As Integer = 1)
Static lngCalc As Long

With Application
  If Modus = 1 Then
    lngCalc = .Calculation
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
    .Calculation = -4135
    .Cursor = xlWait
  Else
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = IIf(lngCalc <> 0, lngCalc, -4105)
    .Cursor = xlDefault
  End If
End With

End Sub

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread