Excel: Verzeichnis durchsuchen und aus Dateien bestimmte Felder übernehmen

Option Explicit

'#### A N P A S S E N ######################################
'Muster zur Review-Datei-Suche
Const c_Ziel_Speicherpfad = C:\Test\Review\Auswertung
Const c_DATEIMUSTER_REVIEWS = Review*.xls


Const c_Ziel_Dateiname = AuswRev_
Const c_Ziel_BltName = AuswRev_
'#### A N P A S S E N ######################################

Const c_BewKrit_K = 1
Const c_BewKrit_B = 2
Const c_BewKrit_F = 3
Const c_BewKrit_P = 4
Const c_BewKrit_O = 5
Const c_BewKrit_I = 6
Const c_BewKrit_andere = 7

Type myReviewAusw_structure
  s_Verantwortlicher              As String
  BewKrit(1 To c_BewKrit_andere)  As Long
End Type

'Blattbeschreibung Ziel
Const c_RevZ_Ueberschrift = 1
Const c_RevZ_ERSTEWERTEZEILE = c_RevZ_Ueberschrift + 1
Const c_RevSP_Verz = 1:         Const c_RevSP_Verz_TXT = Verzeichnis
Const c_RevSP_Datei = 2:        Const c_RevSP_Datei_TXT = Dateiname
Const c_RevSP_E10 = 3:          Const c_RevSP_E10_TXT = E10
Const c_RevSP_G8 = 4:           Const c_RevSP_G8_TXT = G8
Const c_RevSP_D5 = 5:           Const c_RevSP_D5_TXT = D5
Const c_RevSP_H2 = 6:           Const c_RevSP_H2_TXT = H2
Const c_RevSP_B3 = 7:           Const c_RevSP_B3_TXT = B3
Const c_RevSP_D6 = 8:           Const c_RevSP_D6_TXT = D6
Const c_RevSP_B29 = 9:          Const c_RevSP_B29_TXT = B29
Const c_RevSP_C29 = 10:         Const c_RevSP_C29_TXT = C29
Const c_RevSP_D29 = 11:         Const c_RevSP_D29_TXT = D29
Const c_RevSP_E29 = 12:         Const c_RevSP_E29_TXT = E29
Const c_RevSP_F29 = 13:         Const c_RevSP_F29_TXT = F29
Const c_RevSP_G29 = 14:         Const c_RevSP_G29_TXT = G29
Const c_RevSP_H29 = 15:         Const c_RevSP_H29_TXT = H29
Const c_RevSP_Verantw = 16:     Const c_RevSP_Verantw_TXT = Verantwortlich
Const c_RevSP_BewKrK = 17:      Const c_RevSP_BewKrK_TXT = Bew.-Kr. K
Const c_RevSP_BewKrB = 18:      Const c_RevSP_BewKrB_TXT = Bew.-Kr. B
Const c_RevSP_BewKrF = 19:      Const c_RevSP_BewKrF_TXT = Bew.-Kr. F
Const c_RevSP_BewKrP = 20:      Const c_RevSP_BewKrP_TXT = Bew.-Kr. P
Const c_RevSP_BewKrO = 21:      Const c_RevSP_BewKrO_TXT = Bew.-Kr. O
Const c_RevSP_BewKrI = 22:      Const c_RevSP_BewKrI_TXT = Bew.-Kr. I
Const c_RevSP_BewKrandere = 23: Const c_RevSP_BewKrandere_TXT = Bew.-Kr. andere

'Beschreibung der Quelldatei
Const c_QBlt_Daten = Datenblatt
Const c_QBlt_Review = Reviewprotokoll
Const c_Q_ERSTEWERTEZEILE = 5
Const c_QSP_BestZeilen = 5 ->Spalte E zur Bestimmung der letzten Zeile
Const c_QSP_BewKr = 6       'Spalte F
Const c_QSP_Verantw = 7     'Spalte G
Const c_QSP_SollDatum = 8   'Spalte H
Const c_QSP_IstDatum = 9   ->Spalte H
'************************************************************************************
'ich möchte eine Exeldatei erstellen die in bestimmten Verzeichnissen nach
'bestimmten Dateien (z.B. Review*.xls) sucht und hier bestimmte Zellen übernimmt.
'
'Es muss die möglichkeit bestehen die Suche mehrmals durchlaufen zu lassen.
'
'Such Verzeichnis und Dateinamen z.B.:
'Im Verzeichnis C:\Review\Review und allen Unterordnern
'nach Dateien der Form Review*.xls
'
'Die Übernommenen Zellen aus den Dateien:
'Datenblatt: H2,D5,B3,D6,E10,G8,B29: H29
'
'Reviewprotokoll:
'Hier wird es kompliziert:
'In der Spalte F stehen Bewertungskriterien (z.B.: K,B,F,P,O,I,...)
'In der Spalte G sind die Verantwortlichen
'In der Spalte H ist der gewünschte Erledigungsdatum
'In der Spalte I ist dann der Ist-Erledigungstermin
'
'Ich hätte jetzt gerne die offenen, also alle Felder der Spalte I gezählt in Abhängigkeiten der
'Bewertungskriterien und Verantwortlichen und dann Ausgegeben.
'
'Die Ausgabe DAtei könnte So aussehen:
'
'Verzeichnis Dateiname Inhalt E10 
'Inhalt G8 Inhalt D5 Inhalt H2 Inhalt B3 Inhalt D6 Inhalte B29:H29
'Verantwortlich Bewertungskriterien K Bewertungskriterien B Bewertungskriterien F
'Bewertungskriterien P Bewertungskriterien O Bewertungskriterien I
'
Sub ReviewStatistikSammler()

  Dim wba As Workbook, wsa As Worksheet
  Dim wbq As Workbook, wsqd As Worksheet, wsqr As Worksheet
  Dim wbz As Workbook, wsz As Worksheet
  Dim f_Rev() As myFiles_structure, f_Rev_cnt As Long
  Dim l_zz As Long, l_zq As Long, l_rev As Long
  Dim s_Datum As String, s_ZieldateiName As String
  Dim s_SuchPfad As String

 ->Eingabe des Suchpfades
  s_SuchPfad = VerzeichnisAuswahl(Bitte wählen Sie den Suchpfad aus)
  If s_SuchPfad =  Then Exit Sub


  Application.StatusBar = Dateien suchen
  If Not ReviewFilesSuchen(s_SuchPfad, c_DATEIMUSTER_REVIEWS, f_Rev(), f_Rev_cnt) Then
    MsgBox (Fehler bei Suche der Review-Files)
    GoTo AUFRAEUMEN
  End If

 ->aktives Arbeitsblatt merken
  Set wba = ActiveWorkbook: Set wsa = ActiveSheet
  
 ->Bildschirm-Update abschalten
  Application.ScreenUpdating = False
  
 ->Ziel-Mappe anlegen
  Application.StatusBar = Ziel-Datei anlegen
  Call ZielmappeAnlegen(wbz, wsz)
  
  
 ->nächste Wertezeile im Ziel
  l_zz = c_RevZ_ERSTEWERTEZEILE
  
 ->Review-Mappen nacheinander bearbeiten
  For l_rev = 1 To f_Rev_cnt
    On Error Resume Next
   ->Datei Öffnen
    Workbooks.Open FileName:=f_Rev(l_rev).s_VollerPafd
    If Err.Number <> 0 Then
      Err.Clear
      MsgBox (Fehler beim Öffnen von  & vbLf & f_Rev(l_rev).s_VollerPafd)
      GoTo AUFRAEUMEN
    End If
    Set wbq = ActiveWorkbook
    Set wsqd = wbq.Worksheets(c_QBlt_Daten)
    If Err.Number <> 0 Then
      Err.Clear
      MsgBox (Blatt-> & c_QBlt_Daten &-> nicht vorhanden. & vbLf & f_Rev(l_rev).s_VollerPafd)
      GoTo AUFRAEUMEN
    End If
    Set wsqr = wbq.Worksheets(c_QBlt_Review)
    If Err.Number <> 0 Then
      Err.Clear
      MsgBox (Blatt-> & c_QBlt_Review &-> nicht vorhanden. & vbLf & f_Rev(l_rev).s_VollerPafd)
      GoTo AUFRAEUMEN
    End If
    On Error GoTo 0
    
   ->Verarbeiten
    Application.StatusBar = Ergebnis eintragen aus:  & f_Rev(l_rev).s_Dateiname
    Call ReviewVerarbeitenUndWerteInZieldateiEintragen(wsz, l_zz, wsqd, wsqr, wbq)
    
   ->Datei schliessen
    wbq.Close Savechanges:=False
  Next
  
 ->Ziel-Datei Restbearbeitung
  Application.StatusBar = Ende-Bearbeitung der Zieldatei

 ->Nach Pfad, Dateiname, Verantwortlichem sortieren
  wsz.UsedRange.Sort _
    Key1:=wsz.Columns(c_RevSP_Verz), Order1:=xlAscending, _
    Key1:=wsz.Columns(c_RevSP_Datei), Order1:=xlAscending, _
    Key1:=wsz.Columns(c_RevSP_Verantw), Order1:=xlAscending, _
    Header:=xlYes
  
 ->Spaltenbreite optimieren und Zoom 75%
  wsz.UsedRange.EntireColumn.AutoFit
  wsz.Activate: ActiveWindow.Zoom = 75
  
 ->Blattnamen vergeben
  s_Datum = Format(Now(), yyyymmdd_hhnnss)
  wsz.Name = c_Ziel_BltName & s_Datum
  
 ->Pagesetup
  With wsz.PageSetup
   .Orientation = xlLandscape   ->xlPortrait->xlLandscape
   .LeftHeader = &Arial,Fett&16 Marquardt
   .CenterHeader = &Arial,Fett&12Auswertung der offenen Reviewpunkte
   .RightHeader = Format(Now(), dd.mm.yyyy)
   .LeftFooter = Ersteller: Sahin Duygun
   .CenterFooter = &P / &N
   .RightFooter = wbz.FullName & ,  & wsz.Name
   .Zoom = False
   .FitToPagesWide = 1
   .FitToPagesTall = 150
  End With
  
 ->Zieldatei speichern
  On Error Resume Next
  s_ZieldateiName = c_Ziel_Speicherpfad & Application.PathSeparator & c_Ziel_Dateiname & s_Datum & .xls
  wbz.SaveAs FileName:=s_ZieldateiName
  If Err.Number <> 0 Then
    Err.Clear
    MsgBox (Zieldatei konnte nicht gespeichert werden. & vbLf & s_ZieldateiName)
    GoTo AUFRAEUMEN
  Else
    On Error GoTo 0
    wbz.Close Savechanges:=False
    Application.ScreenUpdating = True
    MsgBox (Ergebnisfile:  & s_ZieldateiName)
  End If
  
  
AUFRAEUMEN:
  Application.StatusBar = 
  On Error GoTo 0
  wsa.Activate
  Set wba = Nothing: Set wsa = Nothing
  Set wbq = Nothing: Set wsqd = Nothing: Set wsqr = Nothing
  Set wbz = Nothing: Set wsz = Nothing
End Sub
Private Function ReviewVerarbeitenUndWerteInZieldateiEintragen( _
                  wsz As Worksheet, l_zz As Long, wsqd As Worksheet, wsqr As Worksheet, wbq As Workbook)
                  
  Dim f_RevAw() As myReviewAusw_structure, f_RevAw_cnt As Long
  Dim v As Long
  
 ->Rückgabefeld initialisieren
  ReDim f_RevAw(1 To 1): f_RevAw_cnt = 0

  Call ReviewBlattAuswerten(wsqr, f_RevAw(), f_RevAw_cnt)
  
  For v = 1 To f_RevAw_cnt
   ->Pfad, Datei eintragen
    wsz.Cells(l_zz, c_RevSP_Verz).Value = wbq.Path
    wsz.Cells(l_zz, c_RevSP_Datei).Value = wbq.Name
   ->Werte aus Datenblatt eintragen
    Call WerteAusDatenblattUebertragen(wsz, l_zz, wsqd)
    
   ->Werte aus Auswertung eintragen
    With f_RevAw(v)
      wsz.Cells(l_zz, c_RevSP_Verantw).Value = .s_Verantwortlicher
      wsz.Cells(l_zz, c_RevSP_BewKrK).Value = .BewKrit(c_BewKrit_K)
      wsz.Cells(l_zz, c_RevSP_BewKrB).Value = .BewKrit(c_BewKrit_B)
      wsz.Cells(l_zz, c_RevSP_BewKrF).Value = .BewKrit(c_BewKrit_F)
      wsz.Cells(l_zz, c_RevSP_BewKrP).Value = .BewKrit(c_BewKrit_P)
      wsz.Cells(l_zz, c_RevSP_BewKrO).Value = .BewKrit(c_BewKrit_O)
      wsz.Cells(l_zz, c_RevSP_BewKrI).Value = .BewKrit(c_BewKrit_I)
      wsz.Cells(l_zz, c_RevSP_BewKrandere).Value = .BewKrit(c_BewKrit_andere)
    End With
    
   ->nächste Zeile
    l_zz = l_zz + 1
  Next

End Function
Private Function ReviewBlattAuswerten(wsqr As Worksheet, f_RevAw() As myReviewAusw_structure, f_RevAw_cnt As Long)
  
  Dim l_rows As Long, z As Long, v As Long, b_gefunden As Boolean
  Dim s_Verantwortlicher As String, s_BewKriterium As String, l_BewKriterium As Long
  
  
 ->letzte Zeile feststellen
  l_rows = wsqr.Cells(wsqr.Rows.Count, c_QSP_BestZeilen).End(xlUp).Row
  
 ->Alle Zeilen asuwerten
  For z = c_Q_ERSTEWERTEZEILE To l_rows
   ->pruefen, Soll-Datum leer
    If wsqr.Cells(z, c_QSP_IstDatum).Value =  Then
      s_Verantwortlicher = wsqr.Cells(z, c_QSP_Verantw).Value
      s_BewKriterium = UCase(wsqr.Cells(z, c_QSP_BewKr).Value)
      If s_BewKriterium = K Then
        l_BewKriterium = c_BewKrit_K
      ElseIf s_BewKriterium = B Then
        l_BewKriterium = c_BewKrit_B
      ElseIf s_BewKriterium = F Then
        l_BewKriterium = c_BewKrit_F
      ElseIf s_BewKriterium = P Then
        l_BewKriterium = c_BewKrit_P
      ElseIf s_BewKriterium = O Then
        l_BewKriterium = c_BewKrit_O
      ElseIf s_BewKriterium = I Then
        l_BewKriterium = c_BewKrit_I
      Else
        l_BewKriterium = c_BewKrit_andere
      End If

     ->Verantwortlichen in Auswertungs-Struktur suchen
      b_gefunden = False
      For v = 1 To f_RevAw_cnt
        If s_Verantwortlicher = f_RevAw(v).s_Verantwortlicher Then
          b_gefunden = True
         ->Kriterium zählen
          f_RevAw(v).BewKrit(l_BewKriterium) = f_RevAw(v).BewKrit(l_BewKriterium) + 1
        End If
      Next
      If Not b_gefunden Then
       ->neuen Verantwortlichen eintragen
        f_RevAw_cnt = f_RevAw_cnt + 1: ReDim Preserve f_RevAw(1 To f_RevAw_cnt)
        f_RevAw(f_RevAw_cnt).s_Verantwortlicher = s_Verantwortlicher
       ->Kriterium zählen
        f_RevAw(v).BewKrit(l_BewKriterium) = 1
      End If
    End If
  Next

End Function
Private Function WerteAusDatenblattUebertragen(wsz As Worksheet, l_zeile As Long, wsqd As Worksheet)
  
  wsz.Cells(l_zeile, c_RevSP_E10).Value = wsqd.Range(E10).Value
  wsz.Cells(l_zeile, c_RevSP_G8).Value = wsqd.Range(G8).Value
  wsz.Cells(l_zeile, c_RevSP_D5).Value = wsqd.Range(D5).Value
  wsz.Cells(l_zeile, c_RevSP_H2).Value = wsqd.Range(H2).Value
  wsz.Cells(l_zeile, c_RevSP_B3).Value = wsqd.Range(B3).Value
  wsz.Cells(l_zeile, c_RevSP_D6).Value = wsqd.Range(D6).Value
  wsz.Cells(l_zeile, c_RevSP_B29).Value = wsqd.Range(B29).Value
  wsz.Cells(l_zeile, c_RevSP_C29).Value = wsqd.Range(C29).Value
  wsz.Cells(l_zeile, c_RevSP_D29).Value = wsqd.Range(D29).Value
  wsz.Cells(l_zeile, c_RevSP_E29).Value = wsqd.Range(E29).Value
  wsz.Cells(l_zeile, c_RevSP_F29).Value = wsqd.Range(F29).Value
  wsz.Cells(l_zeile, c_RevSP_G29).Value = wsqd.Range(G29).Value
  wsz.Cells(l_zeile, c_RevSP_H29).Value = wsqd.Range(H29).Value
  
End Function

Private Function ZielmappeAnlegen(wbz As Workbook, wsz As Worksheet)
  
  Dim x As Long, z As Long
  
 ->Ziel-Mappe anlegen
  Set wbz = Workbooks.Add
  For x = wbz.Worksheets.Count To 2 Step -1
    Application.DisplayAlerts = False
    wbz.Worksheets(x).Delete
    Application.DisplayAlerts = True
  Next

  Set wsz = wbz.Worksheets(1)
  
  z = c_RevZ_Ueberschrift
  
  With wsz.Cells(z, c_RevSP_Verz)
    .Value = c_RevSP_Verz_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_Datei)
    .Value = c_RevSP_Datei_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_E10)
    .Value = c_RevSP_E10_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_G8)
    .Value = c_RevSP_G8_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_D5)
    .Value = c_RevSP_D5_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_H2)
    .Value = c_RevSP_H2_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_B3)
    .Value = c_RevSP_B3_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_D6)
    .Value = c_RevSP_D6_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_B29)
    .Value = c_RevSP_B29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_C29)
    .Value = c_RevSP_C29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_D29)
    .Value = c_RevSP_D29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_E29)
    .Value = c_RevSP_E29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_F29)
    .Value = c_RevSP_F29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_G29)
    .Value = c_RevSP_G29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_H29)
    .Value = c_RevSP_H29_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_Verantw)
    .Value = c_RevSP_Verantw_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrK)
    .Value = c_RevSP_BewKrK_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrB)
    .Value = c_RevSP_BewKrB_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrF)
    .Value = c_RevSP_BewKrF_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrP)
    .Value = c_RevSP_BewKrP_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrO)
    .Value = c_RevSP_BewKrO_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrI)
    .Value = c_RevSP_BewKrI_TXT: .Font.Bold = True
  End With
  With wsz.Cells(z, c_RevSP_BewKrandere)
    .Value = c_RevSP_BewKrandere_TXT: .Font.Bold = True
  End With

End Function

Option Explicit
Type myFiles_structure
  s_Verzeichnis As String
  s_Dateiname   As String
  s_VollerPafd  As String
End Type

'********************************************************************************
Function ReviewFilesSuchen(s_SuchPfad As String, s_DateiMuster As String, _
                                    f() As myFiles_structure, f_cnt As Long) As Boolean
'*** Im Pfad und seinen Unterverzeichnissen wird
'*** nach Musterdateien (Review*.xls) gesucht
'***
'*** Die gefundenen Files werden in Feld f() myFiles_structure
'*** zurückgegeben.
'***
'*** Die Anzahl der zurückgegeben files ist in f_cnt enthalten
'***
'********************************************************************************

  Dim s_QuellDatei As String, s_Pfad As String, s_Dateiname As String, x As Long

 ->Rückgabekennung OK
  ReviewFilesSuchen = True

 ->Rückgabefeld und -zähler initialisieren
  ReDim f(1 To 1): f_cnt = 0
  
 ->Pfad überprüfen
  If Dir(s_SuchPfad, vbDirectory) =  Then
    MsgBox (Suchpfad nicht vorhanden & vbLf & s_SuchPfad)
    ReviewFilesSuchen = False
    Exit Function
  End If
  

  With Application.FileSearch
    .NewSearch
    .LookIn = s_SuchPfad
    .SearchSubFolders = True
    .FileName = s_DateiMuster
   ->.FileType = msoFileTypeExcelWorkbooks
    If .Execute() > 0 Then
      For x = 1 To .FoundFiles.Count
        s_QuellDatei = .FoundFiles(x)
       ->Dateinamen und Pfad aus s_QuellDatei
        Call DateinameUndPfadTrennen(s_QuellDatei, s_Pfad, s_Dateiname)
       ->Vollen Pfad, Pfad, Dateiname in Feld speichern
        f_cnt = f_cnt + 1: ReDim Preserve f(1 To f_cnt)
        f(f_cnt).s_VollerPafd = s_QuellDatei
        f(f_cnt).s_Verzeichnis = s_Pfad
        f(f_cnt).s_Dateiname = s_Dateiname
      Next x
      If f_cnt = 0 Then
        MsgBox (Es wurden keine Files mit dem Datei-Muster & vbLf & s_DateiMuster & vbLf & gefunden.)
        ReviewFilesSuchen = False
        Exit Function
      End If
    Else
      MsgBox (Es wurden keine Files mit dem Datei-Muster & vbLf & s_DateiMuster & vbLf & gefunden.)
      ReviewFilesSuchen = False
      Exit Function
    End If
  End With
End Function


'********************************************************************
Private Function DateinameUndPfadTrennen(s_QuellDatei As String, s_Pfad As String, s_Dateiname As String)

  Dim x As Long, s As String
  
  s_Pfad = s_QuellDatei
  s_Dateiname = 
  
  For x = Len(s_QuellDatei) To 2 Step -1
    s = Mid(s_QuellDatei, x, 1)
    Select Case s
      Case \
        s_Dateiname = Right(s_QuellDatei, Len(s_QuellDatei) - x)
        s_Pfad = Left(s_QuellDatei, x - 1)
        Exit For
    End Select
  Next

End Function

Option Explicit

Public Type typ_BrowseInfo
    hOwner       As Long
    pidlRoot     As Long
    pszDispName  As String
    lpszTitle    As String
    ulFlags      As Long
    lpfn         As Long
    lParam       As Long
    iImage       As Long
End Type

Public Declare Function GetDesktopWindow Lib user32 () As Long
Public Declare Function SHBrowseForFolder Lib shell32.dll Alias _
                       SHBrowseForFolderA (lpBrowseInfo As typ_BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib shell32.dll Alias _
                       SHGetPathFromIDListA (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Sub CoTaskMemFree Lib OLE32.dll (ByVal pv As Long)

'********************************************************************
Public Function VerzeichnisAuswahl(Optional s_DialgTitel As String = vbNullString) As String
' Ruft den Verzeichnisauswahldialog auf
' Eingang: s_DialgTitel - optionaler Dialogtitel
' Retrun : ausgewählter Ordner
'********************************************************************
    Dim BI As typ_BrowseInfo, lPidl As Long, sPath As String * 260
    
    On Error Resume Next
    BI.hOwner = GetDesktopWindow()
    BI.pidlRoot = 0&
    BI.ulFlags = &H1->BIF_RETURNONLYFSDIRS
    If Len(s_DialgTitel) = 0 Then BI.lpszTitle = Bitte wählen Sie ein Verzeichnis: _
                             Else BI.lpszTitle = s_DialgTitel
    lPidl = SHBrowseForFolder(BI)
    If SHGetPathFromIDList(ByVal lPidl, ByVal sPath) Then _
        VerzeichnisAuswahl = VBA.Left(sPath, VBA.InStr(sPath, vbNullChar) - 1)
    Call CoTaskMemFree(lPidl)
    On Error GoTo 0
End Function

Private Function Test_VerzeichnisAuswahl()
  Dim s_tmp As String
  s_tmp = VerzeichnisAuswahl(Mein Dialog)

End Function