Comboboxen in abhängikeit

[Steffl]

Hallo Michael,

mal ungetestet

Code:

Private Sub cbDokument_Click()
  Dim strText As String
  Dim varText As Variant

'  strText = strOrdner(cbDokument.ListIndex)
  strText = cbDokument.Value
  Erase strOrdner
  fncOrdner strText, strOrdner()


  For lngCounter = 0 To UBound(strOrdner)
     varText = Split(strOrdner(lngCounter), "\")
     If UBound(varText) > -1 Then ListBox1.AddItem varText(UBound(varText))
  Next lngCounter
    
End Sub

[michel34497]

Hallo!
Leider geht das auch nicht!
Habe von einen bekannten einen Code bekommen der so läuft wie ich es erstmal möchte.
Der bekannte kann mir aber nicht mehr weiterhelfen, da er Beruflich in den nächsten 8 wochen nicht mehr erreichbar ist.
Darum bitte ich euch wenn es möglich ist, mir weiter zu helfen!
@ Stefan schau dir den Code bitte mal an.
@ Alle! Die mit VBA sich auskennen
Bis jetzt sind wir soweit das in der CB was ausgewählt werden kann und dann in der LB1 erscheint
Ich habe ja die UF anders gestaltet wie am anfang, Aus CB2 ist eine LB1 geworden. Die LB1 ist mit MultiSelect.
Nun möchte ich, wenn in LB1 ein oder mehrere Odrner über MultiSelect ausgewählt werden, die dazugehörigen .xls Dateien in der LB2 erscheinen.
Diese sollen dann auch wieder über MultiSelecti n der LB2 angewählt werden können um dann etwas anderes weiter zu Verarbeiten,
Hat einer eine Idee wie?
Ich arbeite auch schon dran (auf Grundlage von diesen Code), aber bis jetzt mit nur mit mißerfolgen!

[Steffl]

Hallo Michael,

mal einen Vorschlag den ich leider nicht testen kann. Das ganze funktioniert bzw. sollte mit einem Doppelclick in der Listbox1 funktionieren.

Code:

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
   Dim lngC As Long
  
   ListBox2.Clear
   For lngC = 0 To ListBox1.Count - 1
      If ListBox1.Selected(lngC) Then prcDateien "N:\Wartungspläne\" & cbDokument.Value & "\" & ListBox1.List(lngC) & "\"
   Next lngC
End Sub

und die andere Prozedur dazu

Code:

Sub prcDateien(strPath As String)
   Dim objFSO As Object, objFolder As Object, objDatei As Object
  
   On Error Resume Next
   Set objFSO = CreateObject("Scripting.FileSystemObject")
   Set objFolder = objFSO.getfolder(strPath)
      
   For Each objDatei In objFolder.Files
      If InStr(objDatei.Name, ".xls*") Then ListBox2.AddItem objDatei.Name
   Next objDatei
  
   Set objFolder = Nothing
   Set objFSO = Nothing
End Sub

[michel34497]

Hallo Stefan!

Danke für die Hilfe.

Leider schreibt der Code nicht in die ListBox2

Code:

If InStr(objDatei.Name, ".xls*") Then ListBox2.AddItem objDatei.Name

Ich sehe in dem Lokalfenster das in der objDatei alles richtig steht.
Bin aber noch nicht dahinter gekommen warum er in  InStr  das nicht findet.
Falls noch Ideen da sind ruhig melden
Probiere weiter es herauszufinden.

[Kuwer]

Hallo Michael,

probiere es mal ohne *.

Gruß Uwe

[michel34497]

Danke Uwe!

So sehe ich jetzt die xls Dateien in der ListBox2.

Danke an alle nochmals die sich mit diesen Thema beschäftigt haben.

[michel34497]

Hallo Leute!

Habe da nochmal ein bis ? fragen.

Habe in der ListBox1 Multiselect eingebaut.
Wie muss der Code abgeändert werden, das wenn ich nur einen Click mache der Code dann ausgeführt wird?

Code:

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
  Dim lngC As Long
 
  ListBox2.Clear
 
  With Me.ListBox2
   .AddItem "Alle"
  End With

  For lngC = 0 To ListBox1.ListCount - 1
     If ListBox1.Selected(lngC) Then prcDateien "D:\Wartungspläne\" & cbDokument.Value & "\" & ListBox1.List(lngC) & "\"
  Next lngC
End Sub
Sub prcDateien(strPath As String)
  Dim objFSO As Object, objFolder As Object, objDatei As Object
 
  On Error Resume Next
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.getfolder(strPath)
     
  For Each objDatei In objFolder.Files
     If InStr(objDatei.Name, ".xls") Then ListBox2.AddItem objDatei.Name
  Next objDatei
 
  Set objFolder = Nothing
  Set objFSO = Nothing
End Sub

Wenn ich diese Zeile so ändere gibt es Fehler

Code:

Private Sub ListBox1_Click(ByVal Cancel As MSForms.ReturnBoolean)

Nächste frage ist, wie kann ich mit diesen Multiselect alle Auflistungen auf einmale in der ListBox aktivieren

Code:

With Me.ListBox1
.AddItem "Alle"
End With

Also wenn "Alle" angewählt wird sollen alle anderen die in der ListBox1 erscheinen auch einen haken haben.

Code:

Private Sub cbDokument_Click()
 Dim strText As String
 Dim varText As Variant

 strText = strOrdnerEbene1(cbDokument.ListIndex)
 Erase strOrdnerEbene2
 ListBox1.Clear                                        'Fenster löschen
 ListBox2.Clear                                        'Fenster löschen
 strOrdnerEbene2() = fncOrdner(strText)
' Für auswahl von allen Ordnern

With Me.ListBox1
.AddItem "Alle"
End With

 For lngCounter = 0 To UBound(strOrdnerEbene2)
    varText = Split(strOrdnerEbene2(lngCounter), "\")
    If UBound(varText) > -1 Then ListBox1.AddItem varText(UBound(varText))
 Next lngCounter
   
End Sub

Wie geht das und wer kann mir einen Tipp geben?

[Steffl]

Hallo Michael,

halte ich zwar für etwas ungünstig weil das Ereignis bei jedem Klicken in dem Element ausgeführt wird aber mal ungetestet

Code:

Private Sub ListBox1_Click()

Zu der Geschichte mit allen Elemente auswählen. Stelle die Multiselect-Eigenschaft auf fmMultiSelectExtended.

Und lies auch mal das bevor du nur den Namen des Ereignis änderst Dropdown in Modulen

[michel34497]

Hallo Experten!

Muss das Thema nochmals ins Spiel bringen!

Der Code, so wie es am anfang beschrieben habe funktioniert.
Nun möchte ich gerne, nicht mehr alle Ordner vom Laufwerk einlesen sondern nur bestimmte die ich im Code vorgebe.
Diese werden bei der UserForm_Initializer in den ListBox3 geschrieben

Code:

Private Sub UserForm_Initialize()
  Dim varText As Variant

   With Me.LListBox3
       .AddItem "Arburg"
       .AddItem "Boy"
       .AddItem "Demag"
       .AddItem "Engel"
        .AddItem "Ferromatik"
       .AddItem "KraussMaffei"
       .AddItem "Windsor"
       .ListIndex = -1        'Vorbelegung "" bei Formularstart
   End With
     
  TextBox6 = Lauf
 
  strOrdnerEbene1() = fncOrdner(Lauf)
  For lngCounter = 0 To UBound(strOrdnerEbene1)
     varText = Split(strOrdnerEbene1(lngCounter), "\")
     cbDokument.AddItem varText(UBound(varText))
     LBOrdner.AddItem varText(UBound(varText))
     
  Next lngCounter
  lngCounter = 0
 
   With Me.cbQar
       .AddItem "Kontrollkarte 1. Quartal"
       .AddItem "Kontrollkarte 2. Quartal"
       .AddItem "Kontrollkarte 3. Quartal"
       .AddItem "Kontrollkarte 4. Quartal"
       .ListIndex = -1        'Vorbelegung "" bei Formularstart
   End With
 

   Cbjahr.List = [row(2014:2030)]
    Me.CommandButton3.BackColor = vbGreen
    Me.CommandButton3.Caption = "Alle Ordner auswählen"
    Zähler1 = 0

    Me.CommandButton4.BackColor = vbGreen
    Me.CommandButton4.Caption = "Alle Unterordner auswählen"
    Zähler2 = 0
    Me.CommandButton5.BackColor = vbGreen
    Me.CommandButton5.Caption = "Alle Dateien auswählen"
    Zähler3 = 0

End Sub

Was muss beim folgenden Code umgeschrieben werden damit auch nur die in ListBox3 angewählten Ordner in den anderen ListBoxen angezeigt und weiter verarbeitet können

Code:

Option Explicit
Const Lauf = "D:\Wartungspläne\"
Private lngCounter As Long
Private strOrdnerEbene1() As String
Private strOrdnerEbene2() As String
Private strOrdnerEbene3() As String
Private lngCounter1 As Long
Public varTextQar As Variant
Public varTextjahr As Variant
Public count As Long
Public aktiv As Boolean
Public Zähler1
Public Zähler2
Public Zähler3

Private Sub Cbjahr_Change()
varTextjahr = Cbjahr.Value     'Box um Jahr auszuwählen
End Sub

Private Sub cbQar_Change()
varTextQar = cbQar.Value
End Sub

Private Sub CommandButton3_Click()
Dim i As Integer
Dim lngZ As Long
Dim NLBOrdner As Long
With Me.CommandButton3
   If .BackColor = vbGreen Then
     .BackColor = &H80FF&    'orange
     .Caption = "Alles abwählen"
     Zähler1 = 1
   Else
       Me.CommandButton3.BackColor = vbGreen
       Me.CommandButton3.Caption = "Alle auswählen"
       Zähler1 = 0
   End If
 End With
 
 If Zähler1 = 1 Then
   ListBox2.Clear
   MsgBox "Alle ausgewählt"
   For i = 0 To Start.LBOrdner.ListCount - 1          'für jede Zeile der Listbox1
       Start.LBOrdner.Selected(i) = True
   Next i
 Else
 
  For i = 0 To Start.LBOrdner.ListCount - 1          'für jede Zeile der Listbox1
       Start.LBOrdner.Selected(i) = False
   Next i
   ListBox1.Clear
  End If

 With LBOrdner
 If .ListCount Then
      For lngZ = 0 To LBOrdner.ListCount - 1
           
           If LBOrdner.Selected(lngZ) Then
               Dim strText As String
               Dim varText As Variant

               strText = strOrdnerEbene1(LBOrdner.ListIndex)
 
 Erase strOrdnerEbene2
 strOrdnerEbene2() = fncOrdner(strText)

 For lngCounter = 0 To UBound(strOrdnerEbene2)
    varText = Split(strOrdnerEbene2(lngCounter), "\")
    If UBound(varText) > -1 Then ListBox1.AddItem varText(UBound(varText))
 Next lngCounter
   End If
   
   NLBOrdner = .ListIndex + 1
   If NLBOrdner > .ListCount - 1 Then
     .ListIndex = 0
   Else
     .ListIndex = NLBOrdner
   End If
   Next lngZ
 End If
End With
End Sub

Private Sub CommandButton4_Click()
Dim i As Integer
Dim lngC As Long
Dim lngZ As Long
Dim NLBOrdner2 As Long

With Me.CommandButton4
   If .BackColor = vbGreen Then
     .BackColor = &H80FF&    'orange
     .Caption = "Alle Ordner abwählen"
     Zähler2 = 1
   Else
       Me.CommandButton4.BackColor = vbGreen
       Me.CommandButton4.Caption = "Alle Ordner auswählen"
       Zähler2 = 0
   End If
 End With
 
 If Zähler2 = 1 Then
   ListBox2.Clear
   MsgBox "Alle ausgewählt"
   For i = 0 To Start.ListBox1.ListCount - 1          'für jede Zeile der Listbox1
       Start.ListBox1.Selected(i) = True
   Next i
 Else
 
  For i = 0 To Start.ListBox1.ListCount - 1          'für jede Zeile der Listbox1
       Start.ListBox1.Selected(i) = False
   Next i
   ListBox2.Clear
 End If
 
 
  With LBOrdner
 If .ListCount Then
      For lngZ = 0 To LBOrdner.ListCount - 1
           
           If LBOrdner.Selected(lngZ) Then
               Dim strText As String
               Dim varText As Variant

               strText = strOrdnerEbene1(LBOrdner.ListIndex)
 
 Erase strOrdnerEbene2
 strOrdnerEbene2() = fncOrdner(strText)

 For lngCounter = 0 To UBound(strOrdnerEbene2)
    varText = Split(strOrdnerEbene2(lngCounter), "\")
    If UBound(varText) > -1 Then ListBox2.AddItem varText(UBound(varText))
 Next lngCounter
   End If
   
   NLBOrdner2 = .ListIndex + 1
   If NLBOrdner2 > .ListCount - 1 Then
     .ListIndex = 0
   Else
     .ListIndex = NLBOrdner2
   End If
   Next lngZ
 End If
End With
 
 For lngC = 0 To ListBox1.ListCount - 1
     If ListBox1.Selected(lngC) Then prcDateien strOrdnerEbene1(LBOrdner.ListIndex) & "\" & ListBox1.List(lngC) & "\"
  Next lngC
 
End Sub

Private Sub CommandButton5_Click()
Dim i As Integer
Dim lngC As Long

With Me.CommandButton5
   If .BackColor = vbGreen Then
     .BackColor = &H80FF&    'orange
     .Caption = "Alle Dateien abwählen"
     Zähler3 = 1
   Else
       Me.CommandButton5.BackColor = vbGreen
       Me.CommandButton5.Caption = "Alle Dateien auswählen"
       Zähler3 = 0
   End If
 End With
 
 If Zähler3 = 1 Then
   
   MsgBox "Alle ausgewählt"
   For i = 0 To Start.ListBox2.ListCount - 1          'für jede Zeile der Listbox1
       Start.ListBox2.Selected(i) = True
   Next i
 Else
 
  For i = 0 To Start.ListBox2.ListCount - 1          'für jede Zeile der Listbox1
       Start.ListBox2.Selected(i) = False
   Next i
   For i = 0 To Start.ListBox1.ListCount - 1          'für jede Zeile der Listbox1
       Start.ListBox1.Selected(i) = False
   Next i
   
   ListBox2.Clear
   
    Me.CommandButton4.BackColor = vbGreen
    Me.CommandButton4.Caption = "Alle Ordner auswählen"
    Zähler2 = 0
   
  End If
End Sub

Private Sub CoBuDrucken_Click()
Dim lngC As Long
'Dim lListBox2  As Long
Dim i As Integer
Dim blnAuswahl As Boolean
 
' Ist etwas ausgewäht?
With ListBox2
  For i = 0 To .ListCount - 1
    If .Selected(i) Then
      blnAuswahl = True
      Exit For
    End If
  Next i
End With
If blnAuswahl = False Then
  MsgBox "Nichts ausgwählt!"
   
     Exit Sub
     '
     ElseIf varTextQar = "" Then                                   ' Wenn Nichts angwählt
           MsgBox "Kein Quartal ausgewählt"
     ElseIf varTextjahr = "" Then                                  ' Wenn Nichts angwählt
           MsgBox "Kein Jahr ausgewählt"
  Else
     Stop 'Wenn alles i.O. dann Code für Drucken
   For lngC = 0 To ListBox2.ListCount - 1
            If ListBox2.Selected(lngC) Then prcDateien2 Lauf & LBOrdner.Value & "\" & ListBox1.List(lngC) & "\"
   Next lngC
 
End If

End Sub

Sub prcDateien2(strPath As String)
  Dim objFSO As Object, objFolder As Object, objDatei As Object
 
  On Error Resume Next
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.getfolder(strPath)

Application.ScreenUpdating = False

  For Each objDatei In objFolder.Files
     If InStr(objDatei.name, ".xls") Then
           Application.StatusBar = "Öffne " & objDatei & "...."
           Workbooks.Open Filename:=objDatei
          Dim name As String
         
          ' Tabellenblatt auswählen
          ActiveWorkbook.Sheets(varTextQar).Select
          ' Jahr einfügen
           Range("H1").FormulaR1C1 = Cbjahr.Value
           Application.StatusBar = "Speichere " & objDatei & "...."
           ActiveWindow.SelectedSheets.PrintOut Copies:=1
           With ActiveWorkbook
               .Save
               .Close
           End With
   
   Application.StatusBar = False
   Application.ScreenUpdating = True
           
        Else
       
       End If
  Next objDatei
 
  Set objFolder = Nothing
  Set objFSO = Nothing
End Sub

Private Sub Image1_Click()
 Unload Start
End Sub

Private Sub LBOrdner_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
 Dim strText As String
 Dim varText As Variant

 If Zähler1 = 1 Then Exit Sub
 strText = strOrdnerEbene1(LBOrdner.ListIndex)
 Erase strOrdnerEbene2
 ListBox1.Clear                                        'Fenster löschen
 ListBox2.Clear                                        'Fenster löschen
 strOrdnerEbene2() = fncOrdner(strText)

 For lngCounter = 0 To UBound(strOrdnerEbene2)
    varText = Split(strOrdnerEbene2(lngCounter), "\")
    If UBound(varText) > -1 Then ListBox1.AddItem varText(UBound(varText))
 Next lngCounter

End Sub

Private Sub UserForm_Initialize()
  Dim varText As Variant
     
  TextBox6 = Lauf
 
  With Me.LListBox3
       .AddItem "Arburg"
       .AddItem "Boy"
       .AddItem "Demag"
       .AddItem "Engel"
       .AddItem "Ferromatik"
       .AddItem "KraussMaffei"
       .AddItem "Windsor"
       .ListIndex = -1        'Vorbelegung "" bei Formularstart
   End With
 
  strOrdnerEbene1() = fncOrdner(Lauf)
  For lngCounter = 0 To UBound(strOrdnerEbene1)
     varText = Split(strOrdnerEbene1(lngCounter), "\")
     cbDokument.AddItem varText(UBound(varText))
     LBOrdner.AddItem varText(UBound(varText))
     
  Next lngCounter
  lngCounter = 0
 
   With Me.cbQar
       .AddItem "Kontrollkarte 1. Quartal"
       .AddItem "Kontrollkarte 2. Quartal"
       .AddItem "Kontrollkarte 3. Quartal"
       .AddItem "Kontrollkarte 4. Quartal"
       .ListIndex = -1        'Vorbelegung "" bei Formularstart
   End With
 

   Cbjahr.List = [row(2014:2030)]
    Me.CommandButton3.BackColor = vbGreen
    Me.CommandButton3.Caption = "Alle Ordner auswählen"
    Zähler1 = 0

    Me.CommandButton4.BackColor = vbGreen
    Me.CommandButton4.Caption = "Alle Unterordner auswählen"
    Zähler2 = 0
    Me.CommandButton5.BackColor = vbGreen
    Me.CommandButton5.Caption = "Alle Dateien auswählen"
    Zähler3 = 0

End Sub


Function fncOrdner(strPath As String) As String()
  Dim objFSO As Object, objFolder As Object, objOrdner As Object
  Dim strOrdner() As String
 
  On Error Resume Next
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.getfolder(strPath)
     
  For Each objOrdner In objFolder.subfolders
     ReDim Preserve strOrdner(0 To lngCounter)
     strOrdner(lngCounter) = objOrdner.Path
     lngCounter = lngCounter + 1
 
  Next objOrdner
 
  fncOrdner = strOrdner
  Set objFolder = Nothing
  Set objFSO = Nothing
End Function
Private Sub cbDokument_Click()
 Dim strText As String
 Dim varText As Variant

 strText = strOrdnerEbene1(cbDokument.ListIndex)
 Erase strOrdnerEbene2
 ListBox1.Clear                                        'Fenster löschen
 ListBox2.Clear                                        'Fenster löschen
 strOrdnerEbene2() = fncOrdner(strText)

 For lngCounter = 0 To UBound(strOrdnerEbene2)
    varText = Split(strOrdnerEbene2(lngCounter), "\")
    If UBound(varText) > -1 Then ListBox1.AddItem varText(UBound(varText))
 Next lngCounter
   
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim lngC As Long
Dim i As Integer

 ListBox2.Clear
 
  For lngC = 0 To ListBox1.ListCount - 1
     If ListBox1.Selected(lngC) Then prcDateien strOrdnerEbene1(LBOrdner.ListIndex) & "\" & ListBox1.List(lngC) & "\"
  Next lngC
End Sub

Sub prcDateien(strPath As String)
  Dim objFSO As Object, objFolder As Object, objDatei As Object
 
  On Error Resume Next
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Set objFolder = objFSO.getfolder(strPath)
     
  For Each objDatei In objFolder.Files
     If InStr(objDatei.name, ".xls") Then ListBox2.AddItem objDatei.name
  Next objDatei
 
  Set objFolder = Nothing
  Set objFSO = Nothing
End Sub

Bei diesen Code werden über ListIndex, 9 Ordner eingelesen habe aber nur noch 7
Habe das mit den jetzigen Code versucht doch wenn ich dann in der ListBox3 "Windsor" anwähle ( ListIndex7) nimmt er mir eine anderen Ordner.
Die Idee den ListIndex zu erhöhen und vergleichen was hinter dem steht sind bis jetzt bei mir gescheitert.


Wenn eine Datei erforderlich ist schreibt eine PN und ich sende sie zu!