Ordner auswählen & eintragen in Makro mittels VBA

[tobisw]

Hallo zusammen,

ich habe ein Makro im Internet gefunden, wo ich aus verschiedenen Exceldateien bestimmte Zellen in eine neue Exceldatei übertrage.
Dies funktioniert echt super - lediglich hätte ich gerne, dass ein Benutzer beim Ausführen des Makros mittels Popup Fenster
den gewünschten Ordner (wo die Dateien liegen) auswählen muss.

Denn momentan ist es so, dass der Pfad zum Ordner manuell im Makro eingetragen werden muss - dies kann ich jedoch nicht von allen Benutzern erwarten bzw. beibringen.

Der momentane Code sieht wie folgt aus:

Code:

blic Sub QAFsauswerten()

   Dim strDateiname As String
   Dim strPfad      As String
   Dim lngZeile     As Long
   
     
'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xls) liegen
   strPfad = "C:\Users\z563164\Desktop\testquaf"
   
   
   'Den 1. Dateinamen holen
   strDateiname = Dir(strPfad & "*.xls")

   'Startzeile festlegen
   lngZeile = 2
   
   'Solange ein Dateiname gelesen wird
   Do While Not strDateiname = ""
       
       'Datei verarbeiten
       Call TabVerarb(strPfad & strDateiname, lngZeile)
       
       'nächsten Dateinamen holen
       strDateiname = Dir()
       
       'Zeilenzähler erhöhen
       lngZeile = lngZeile + 1
    Loop

End Sub

Sprich, die Pfadangabe soll über ein Popup Fenster sich "selber" in das Makro schreiben.

[chris-ka]

Hi,

füge ein neues Modul ein und diesen Code dort einfügen

Code:

' Benötigte API-Deklarationen
Private Type BrowseInfo
    hWndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type
Private Const MAX_PATH = 260
'Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_RETURNONLYFSDIRS = &H40
Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = 1
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hWnd As Long, ByVal Msg As Long, wParam As Any, lParam As Any) As Long
Private m_BrowseInitDir As String

Public Function BrowseForFolder(ByVal sPrompt As String, Optional ByVal sInitDir As String) As String
Dim nPos As Long
Dim nIDList As Long
Dim sPath As String
Dim oInfo As BrowseInfo
    m_BrowseInitDir = sInitDir
    With oInfo
        .hWndOwner = GetActiveWindow()
        .lpszTitle = lstrcat(sPrompt, "")
        .ulFlags = BIF_RETURNONLYFSDIRS
        If sInitDir <> "" Then
            .lpfnCallback = FuncCallback(AddressOf BrowseCallback)
        End If
    End With
    nIDList = SHBrowseForFolder(oInfo)
    If nIDList Then
        sPath = String$(MAX_PATH, 0)
        Call SHGetPathFromIDList(nIDList, sPath)
        Call CoTaskMemFree(nIDList)
        nPos = InStr(sPath, vbNullChar)
        If nPos Then sPath = Left$(sPath, nPos - 1)
    End If
    BrowseForFolder = sPath
End Function

Private Function BrowseCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Select Case uMsg
        Case BFFM_INITIALIZED
            Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, ByVal m_BrowseInitDir)
    End Select
    BrowseCallback = 0
End Function

Private Function FuncCallback(ByVal nParam As Long) As Long
    FuncCallback = nParam
End Function

deinen Code so ändern.

Code:

Sub QAFsauswerten()
    Dim strDateiname As String
    Dim strPfad      As String
    Dim lngZeile     As Long
    Dim Caption As String, s_Verzeichnis As String
        Caption = "Verzeichnisübersicht"
     
 'Pfadangabe, in dem die zu lesenden Excel-Datei (*.xls) liegen
    strPfad = "C:\Users\z563164\Desktop\testquaf"
    strPfad = BrowseForFolder(Caption, strPfad)
   
   
   
    'Den 1. Dateinamen holen
    strDateiname = Dir(strPfad & "*.xls")
    'Startzeile festlegen
    lngZeile = 2
   
    'Solange ein Dateiname gelesen wird
    Do While Not strDateiname = ""
       
        'Datei verarbeiten
        Call TabVerarb(strPfad & strDateiname, lngZeile)
       
        'nächsten Dateinamen holen
        strDateiname = Dir()
       
        'Zeilenzähler erhöhen
        lngZeile = lngZeile + 1
     Loop
End Sub

oder den einfachen Dialog
mit Application.FileDialog(msoFileDialogFolderPicker)
verwenden.
der müsste auch reichen

Code:

Sub QAFsauswerten()

    Dim strDateiname As String
    Dim strPfad      As String
    Dim lngZeile     As Long

With Application.FileDialog(msoFileDialogFolderPicker)
    .InitialFileName = "c:\" '"C:\Users\z563164\Desktop\testquaf"
    .Title = "Ordner"
    .ButtonName = "your Choice :)"
    .InitialView = msoFileDialogViewList
    If .Show = -1 Then
        strPfad = .SelectedItems(1)
        If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
    Else
        strPfad = ""
    End If
End With
If strPfad = "" Then
    Exit Sub
Else
    'Den 1. Dateinamen holen
    strDateiname = Dir(strPfad & "*.xls")

    'Startzeile festlegen
    lngZeile = 2
    
    'Solange ein Dateiname gelesen wird
    Do While Not strDateiname = ""
        
        'Datei verarbeiten
        Call TabVerarb(strPfad & strDateiname, lngZeile)
        
        'nächsten Dateinamen holen
        strDateiname = Dir()
        
        'Zeilenzähler erhöhen
        lngZeile = lngZeile + 1
     Loop
End If
End Sub

[Gast 123]

hallo

Anbei ein kurzes Makro das ich in einem Forum für Dateien auflisten fand. Da gab es auch einen
Codeabschnitt um den Ordner über DialogBox zu suchen. Vielleicht kannst du ihn verwenden?
strFolder müsste in strPfad umbenannt werden!  Dann könnte es klappen.  Einfach mal testen.

Sub DateiListe()
  Dim strFolder As String, wksListe As Worksheet
  
  Application.ScreenUpdating = False
    
  With Application.FileDialog(msoFileDialogFolderPicker)
    .Title = "Ordner wählen"
    .AllowMultiSelect = False
    If .Show = -1 Then
      strFolder = .SelectedItems(1)
    End If
  End With
  
  If strFolder = "" Then Exit Sub

[tobisw]

Hi Christ,

dein zweiter Vorschlag hat einwandfrei funktioniert! Vielen Dank!

[tobisw]

Hallo zusammen,

jetzt hätte ich noch ein Anliegen. Abhängig von einem bestimmen Zellwert, z.Bsp. wenn in B106 der Text "XYZ" steht, soll Makro2 starten.
Wenn in B106 nichts steht, soll Makro1 starten.

Da ich in VBA ehrlich keine Ahnung habe, weiß ich nicht, wie ich das in meinem Code bringen soll. Hintergrund ist, dass die zu durchsuchenden Dateien
unterschiedliche Versionen haben und anhand der Zelle B106 unterschieden werden können.

Danke schonmal für eure Hilfe!
Tobi

[tobisw]

Vielleicht zur Erklärung noch einmal vereinfacht dargestellt. Folgendes soll passieren:

1) Das Makro soll die erste Datei im ausgewählte Ordner öffnen und prüfen ob in Zelle B106 der Text "XYZ" vorkommt.
    Wenn ja, dann soll Makro1 ausgeführt werden.

2) Wenn nein, dann soll Makro2 ausgeführt werden.

Und diese Routine dann für jede Datei, die das Makro öffnet.

Eventuell ist es jetzt besser zu verstehen.

Hoffe, mir kann jemand helfen.

Viele Grüße
Tobi

[schauan]

Hallo Tobi,
welche ist denn die erste? die älteste? die neueste? die erste bei alphabetischer Sortierung? ...
Geht es um Exceldateien? Ich vermute es, da Du Daten aus verschiedenen in eine neue übernehmen willst. Ist die Zelle B106 in der Datei mit dem Makro oder, falls es Excel-Dateien sind, in der zu öffnenden? Wenn letzteres, auf welchem Blatt ist die Zelle B106? ...

[tobisw]

Hallo Andre,

möchte noch etwas Hintergrundinformationen geben.

Es gibt eine Datei, nennen wir Sie Zusammenfassung.xls wo die herausgelesenen Punkte aus den div. anderen Exceldateien (nennen wir Sie Datei1.xls + Datei2.xls usw. - die Anzahl kann unendlich sein) reinkopiert werden sollen. Das klappt auch mit meinem bisherigen Code (siehe unten) auch einwandfrei.

Nun haben wir das Problem, dass es aktuell zwei unterschiedliche Versionen der Datei1 und Datei2 gibt. Grundsätzlich werden in diesen Dateien die gleichen Daten aufgeführt - jedoch je nach Version in unterschiedlichen Zellen. Unterscheidbar sind die Versionen durch einen Eintrag in einer Zelle, z.Bsp. in der Datei1 steht in der Zelle B106=XY. In der Datei2.xls ist diese Zelle leer.

Somit soll das erste Makro prüfen, ob in der Zelle B106 der Datei1.xls etwas hinterlegt ist z.Bsp. der text "XY". Wenn ja --> Rufe Makro1 auf, welches
dann die jeweiligen Daten in dieser Datei anhand des Makro1 herauslist und in die Datei Zusammenfassung.xls schreibt. Wenn die Prüfung ergibt, dass B106 leer ist, dann führe Makro2 durch und lese die Daten aus und speicher Sie in die Datei Zusammenfassung.xls. Und dies für jede einzelne Datei die in diesem Ordner gespeichert ist.

Code:

Option Explicit

Sub QAFsauswerten()

   Dim strDateiname As String
   Dim strPfad      As String
   Dim lngZeile     As Long

With Application.FileDialog(msoFileDialogFolderPicker)
   .InitialFileName = "c:\" '"C:\Users\theodor\Desktop\testquaf"
   .Title = "Ordner"
   .ButtonName = "your Choice :)"
   .InitialView = msoFileDialogViewList
   If .Show = -1 Then
       strPfad = .SelectedItems(1)
       If Right(strPfad, 1) <> "\" Then strPfad = strPfad & "\"
   Else
       strPfad = ""
   End If
End With
If strPfad = "" Then
   Exit Sub
Else
   'Den 1. Dateinamen holen
   strDateiname = Dir(strPfad & "*.xls")

   'Startzeile festlegen
   lngZeile = 2
   
   'Solange ein Dateiname gelesen wird
   Do While Not strDateiname = ""
       
       'Datei verarbeiten
       Call TabVerarb(strPfad & strDateiname, lngZeile)
       
       'nächsten Dateinamen holen
       strDateiname = Dir()
       
       'Zeilenzähler erhöhen
       lngZeile = lngZeile + 1
    Loop
End If
End Sub




Public Sub TabVerarb(strPfad As String, lngZeile As Long)
   Dim strMeSH As String
   Dim strDatei As String
   Dim strSH As String
   
 'Dateinamen extrahieren
   strDatei = Split(strPfad, "\")(UBound(Split(strPfad, "\")))
   
   'Eigenen Namen merken
   strMeSH = ActiveWorkbook.Name
   
   'Datei öffnen
   Workbooks.Open Filename:=strPfad
   
   With Workbooks(strMeSH)
       'Dateinamen und auszuwertenden Zellen übertragen
       .Sheets("Tabelle1").Cells(lngZeile, 1) = strDatei
       .Sheets("Tabelle1").Cells(lngZeile, 2) = Workbooks(strDatei).Sheets("Summary").Range("G16").Value
       .Sheets("Tabelle1").Cells(lngZeile, 3) = Workbooks(strDatei).Sheets("Summary").Range("K8").Value
       .Sheets("Tabelle1").Cells(lngZeile, 4) = Workbooks(strDatei).Sheets("Summary").Range("D27").Value
       .Sheets("Tabelle1").Cells(lngZeile, 5) = Workbooks(strDatei).Sheets("Summary").Range("D26").Value
   .Sheets("Tabelle1").Cells(lngZeile, 6) = Workbooks(strDatei).Sheets("Summary").Range("J27").Value
   .Sheets("Tabelle1").Cells(lngZeile, 7) = Workbooks(strDatei).Sheets("Summary").Range("J28").Value
   .Sheets("Tabelle1").Cells(lngZeile, 8) = Workbooks(strDatei).Sheets("Summary").Range("J29").Value
   .Sheets("Tabelle1").Cells(lngZeile, 9) = Workbooks(strDatei).Sheets("Summary").Range("K29").Value
   .Sheets("Tabelle1").Cells(lngZeile, 10) = Workbooks(strDatei).Sheets("Summary").Range("J31").Value
   .Sheets("Tabelle1").Cells(lngZeile, 11) = Workbooks(strDatei).Sheets("Summary").Range("K31").Value
   .Sheets("Tabelle1").Cells(lngZeile, 12) = Workbooks(strDatei).Sheets("Summary").Range("J32").Value
   .Sheets("Tabelle1").Cells(lngZeile, 13) = Workbooks(strDatei).Sheets("Summary").Range("J35").Value
   .Sheets("Tabelle1").Cells(lngZeile, 14) = Workbooks(strDatei).Sheets("Summary").Range("J37").Value
   .Sheets("Tabelle1").Cells(lngZeile, 15) = Workbooks(strDatei).Sheets("Summary").Range("K37").Value
   .Sheets("Tabelle1").Cells(lngZeile, 16) = Workbooks(strDatei).Sheets("Summary").Range("B40").Value
   .Sheets("Tabelle1").Cells(lngZeile, 17) = Workbooks(strDatei).Sheets("Summary").Range("J48").Value
   .Sheets("Tabelle1").Cells(lngZeile, 18) = Workbooks(strDatei).Sheets("Summary").Range("J49").Value
   .Sheets("Tabelle1").Cells(lngZeile, 19) = Workbooks(strDatei).Sheets("Summary").Range("J57").Value
   .Sheets("Tabelle1").Cells(lngZeile, 20) = Workbooks(strDatei).Sheets("Summary").Range("J64").Value
   .Sheets("Tabelle1").Cells(lngZeile, 21) = Workbooks(strDatei).Sheets("Summary").Range("J65").Value
   .Sheets("Tabelle1").Cells(lngZeile, 22) = Workbooks(strDatei).Sheets("Summary").Range("J66").Value
   .Sheets("Tabelle1").Cells(lngZeile, 23) = Workbooks(strDatei).Sheets("Summary").Range("J72").Value
   .Sheets("Tabelle1").Cells(lngZeile, 24) = Workbooks(strDatei).Sheets("Summary").Range("J73").Value
   .Sheets("Tabelle1").Cells(lngZeile, 25) = Workbooks(strDatei).Sheets("Summary").Range("J74").Value
   .Sheets("Tabelle1").Cells(lngZeile, 26) = Workbooks(strDatei).Sheets("Summary").Range("J80").Value
   .Sheets("Tabelle1").Cells(lngZeile, 27) = Workbooks(strDatei).Sheets("Summary").Range("J82").Value
   .Sheets("Tabelle1").Cells(lngZeile, 28) = Workbooks(strDatei).Sheets("Summary").Range("J83").Value
   .Sheets("Tabelle1").Cells(lngZeile, 29) = Workbooks(strDatei).Sheets("Summary").Range("J84").Value
   .Sheets("Tabelle1").Cells(lngZeile, 30) = Workbooks(strDatei).Sheets("Summary").Range("J93").Value
   .Sheets("Tabelle1").Cells(lngZeile, 31) = Workbooks(strDatei).Sheets("Summary").Range("G94").Value
   .Sheets("Tabelle1").Cells(lngZeile, 32) = Workbooks(strDatei).Sheets("Summary").Range("G95").Value
   .Sheets("Tabelle1").Cells(lngZeile, 33) = Workbooks(strDatei).Sheets("Summary").Range("G98").Value
   .Sheets("Tabelle1").Cells(lngZeile, 34) = Workbooks(strDatei).Sheets("Summary").Range("J103").Value
   .Sheets("Tabelle1").Cells(lngZeile, 35) = Workbooks(strDatei).Sheets("Material").Range("E15").Value
   .Sheets("Tabelle1").Cells(lngZeile, 36) = Workbooks(strDatei).Sheets("Material").Range("J15").Value
   .Sheets("Tabelle1").Cells(lngZeile, 37) = Workbooks(strDatei).Sheets("Material").Range("O15").Value
   .Sheets("Tabelle1").Cells(lngZeile, 38) = Workbooks(strDatei).Sheets("Material").Range("P15").Value
   .Sheets("Tabelle1").Cells(lngZeile, 39) = Workbooks(strDatei).Sheets("Material").Range("Q15").Value
   .Sheets("Tabelle1").Cells(lngZeile, 40) = Workbooks(strDatei).Sheets("Material").Range("R15").Value
   .Sheets("Tabelle1").Cells(lngZeile, 41) = Workbooks(strDatei).Sheets("Material").Range("T15").Value
 
   
   
   
   
   End With
   
   'Quelldatei schließen
   Workbooks(strDatei).Saved = True
   Workbooks(strDatei).Close

End Sub

Habe versucht es zu verständlich wie möglich zu erklären - leider kann ich die Dateien nicht hochladen, da es berufliche Dateien sind.
Tobi

[tobisw]

Hallo Andre,

konnte ich Dir die Sache näher bringen? Solltest du noch weitere Infos benötigen, sag einfach Bescheid.

Grüße
Tobi

[schauan]

Hallo Tobi,

Du musst doch nur an passender Stelle die Prüfung einbauen.

If Sheets("Welchesauchimmer").Range("B106").value ="XY" Then Makro1 Else Makro2