Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Userform
BildScreenshot zu Userform Userform-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema ListBox
BildScreenshot zu ListBox ListBox-Seite mit Beispielarbeitsmappe aufrufen

Auswerten/Selektieren

Betrifft: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 04.08.2014 07:31:47

Guten Tag zusammen.

Nachdem mich die Urlaubsinsel wieder losgelassen hat, begebe ich mich wieder an mein Problem.

Es handelt sich um folgende Beispieldatenbank;

https://www.herber.de/bbs/user/91720.xls

Daraufhin schrieb mir "fcs":

Hallo Thorsten,

ich hab mir deine Datei auch mal angesehen.

Irgendwie passt da irgendetwas überhauptnicht zusammen.
Nach deinem geposteten Code für die Combobox1 hätte ich jetzt einen komplett anderen Aufbau der  _
 _
Teilnahme-Tabelle erwartet.
Die Bezeichnungen oberhalb der Listbox im Userform "Auswertung" sind in der Tabelle "Teilnahme"  _
 _
nicht als Spaltentitel zu finden. Oder kommen die Werte sieser Box später aus einem anderen  _
Tabellenblatt?

Beschreibe mal genau welche Information in der Combobox2 als Auswahlliste erstellt werden soll,  _
 _
wenn in Combox1 ein Ort (Wert aus Spalte F) gewählt wird.
Gibt es die Orte in der Spalte F mehrfach?
Das Format der Uhrzeit in der Auswahlliste ist dabei dann "nur" ein Zusatzproblem.

Gruß
Franz

Und ich komme mal darauf zurück.

Folgende Infos sollen in den Comboboxen selektiert werden(aus Tabelle "Teilnahme":

Combobox1: Ort(Spalte F), Schulform(Spalte C)
Combobox2: Spalte G, Spalte H, Spalte I, Spalte K

In der Listbox soll dann nachdem selektiert wurde, folgendes der Selektion angezeigt werden:

Schulnummer, Schulname, Ort, Schulform, jeweilige Selektion aus Combobox 2

Sollte jetzt in Combobox 2 nichts ausgewählt werden, soll er auch nur nach Combobox 1 selektieren.

Ich hoffe man kann es nachvollziehen.

  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 04.08.2014 10:37:07

Ich habe mal die Datei aktualisiert und den Code etwas angepasst.

Ich bekomme jetzt die Daten in den Comboboxen angezeigt, aber die Zeit ist nicht formatiert.

Weiterhin fehlt mir die Übernahme in die Listbox.

https://www.herber.de/bbs/user/91870.xls


  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 04.08.2014 12:03:54

Hallo Thorsten,

Ich hoffe man kann es nachvollziehen.
Ohne Beispieldaten im Tabellenblatt ist es etwas schwierig.
Ich mal versucht was draus zu machen. Bei den Spalten G/H/I/K könnte man es wohl auch anders machen bzw. ich hab es ggf. auch nicht 100% verstanden. Ich vermute, dass in den Spalte G,H und I nur angekreuzt wird.

Nachfolgend mal der Code für das Userform, wie man es machen könnte. Nicht erschrecken - das Ganze wird dadurch kompliziert, dass die Auswahllisten der Listen nicht direkt aus der Tabelle entnommen werden können, sondern mit vielen Prüfungen/Wertvergleichen per Code zusammengestellt werden müssen.

Gruß
Franz

'Code Userform "Auswertung"
Option Explicit

Private wksData As Worksheet

Private Sub Auswerten_Cmd_Click()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  Dim strOrt As String, strSchulform As String
  Dim strG As String, strH As String, strI As String, strStart As String
  On Error GoTo Fehler
  If Me.ComboBox1.ListIndex = -1 Then
    MsgBox "Bitte erst Ort - Schulform auswählen"
  Else
    With Me.ComboBox1
      strOrt = .List(.ListIndex, 0)
      strSchulform = .List(.ListIndex, 1)
    End With
    
    With Me.ComboBox2
      If .ListIndex > 0 Then
        strG = .List(.ListIndex, 0)
        strH = .List(.ListIndex, 1)
        strI = .List(.ListIndex, 2)
        strStart = .List(.ListIndex, 3)
      Else
        strG = ""
        strH = ""
        strI = ""
        strStart = "Alle"
      End If
    End With
    With wksData
      'Liste für Listbox1 gemäß Auswahl in Comboboxen zustammenstellen
      Set objCol = New Collection
      For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
        If strOrt = .Cells(lngZeile, 6).Value And strSchulform = .Cells(lngZeile, 3).Value Then
          If strStart = "Alle" Then
            objCol.Add lngZeile
          Else
            If strG = .Cells(lngZeile, 7).Text _
                And strH = .Cells(lngZeile, 8).Text _
                And strI = .Cells(lngZeile, 9).Text _
                And strStart = Format(.Cells(lngZeile, 11), "h:mm") Then
              objCol.Add lngZeile
            End If
          End If
        End If
      Next
      
      If objCol.Count > 0 Then
        ReDim arrListe(1 To objCol.Count, 1 To 8)
        For intCol = 1 To objCol.Count
          arrListe(intCol, 1) = .Cells(objCol(intCol), 1)
          arrListe(intCol, 2) = .Cells(objCol(intCol), 2)
          arrListe(intCol, 3) = .Cells(objCol(intCol), 3)
          arrListe(intCol, 4) = .Cells(objCol(intCol), 6)
          arrListe(intCol, 5) = .Cells(objCol(intCol), 7)
          arrListe(intCol, 6) = .Cells(objCol(intCol), 8)
          arrListe(intCol, 7) = .Cells(objCol(intCol), 9)
          arrListe(intCol, 8) = Format(.Cells(objCol(intCol), 11), "h:mm")
        Next
        With Me.ListBox1
          .ColumnCount = 8
          .ColumnWidths = "40pt;100pt;80pt;80pt;40Pt;40Pt;40Pt;60Pt"
          .List = arrListe
          Erase arrListe
        End With
      End If
    End With
    Set objCol = Nothing
  End If
  
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With

  
End Sub


Private Sub ComboBox1_Change()

  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  Dim strOrt As String, strSchulform As String
  On Error GoTo Fehler
  If Me.ComboBox1.ListIndex = -1 Then Exit Sub
  With Me.ComboBox1
    strOrt = .List(.ListIndex, 0)
    strSchulform = .List(.ListIndex, 1)
  End With
  With wksData
    'Liste für "nein, nur vormittags"  "ja, auch nachmittags"  "nur nachmittags" " _
Startzeitpunkt"
      ' zur Auswahl in Combobox1 zusammenstellen
    Set objCol = New Collection
    lngZeile = 1
    'Spaltentitel übernehmen
    objCol.Add lngZeile, Key:=.Cells(lngZeile, 7) & "|" & .Cells(lngZeile, 8) _
        & "|" & .Cells(lngZeile, 9) & "|" & .Cells(lngZeile, 11)
        
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      If strOrt = .Cells(lngZeile, 6).Value And strSchulform = .Cells(lngZeile, 3).Value Then
        objCol.Add lngZeile, Key:=.Cells(lngZeile, 7) & "|" & .Cells(lngZeile, 8) _
            & "|" & .Cells(lngZeile, 9) & "|" & Format(.Cells(lngZeile, 11), "hh:mm")
      End If
    Next
    
    With Me.ComboBox2 'Formatieren/Einrichten
      .ColumnCount = 4
      .ListWidth = 300
      .ControlTipText = "Bei ""Startzeitpunkt"" werden alle Schlen zu Ort/Schulform angezeigt"
      .TextColumn = 4
      .TextAlign = fmTextAlignCenter
      .Clear
    End With
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 4)
      For intCol = 1 To objCol.Count
        arrListe(intCol, 1) = .Cells(objCol(intCol), 7)
        arrListe(intCol, 2) = .Cells(objCol(intCol), 8)
        arrListe(intCol, 3) = .Cells(objCol(intCol), 9)
        arrListe(intCol, 4) = Format(.Cells(objCol(intCol), 11), "h:mm")
      Next
      Me.ComboBox2.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub

Private Sub UserForm_activate()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  On Error GoTo Fehler
  Set wksData = Worksheets("Teilnahme")
  With wksData
    'Liste Ort - Schulformen zusammenstellen
    Set objCol = New Collection
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      objCol.Add lngZeile, Key:=.Cells(lngZeile, 6) & "|" & .Cells(lngZeile, 3)
    Next
    
    With Me.ComboBox1
      .ColumnCount = 3
      .ListWidth = 150
      .TextColumn = 3
      .Clear
    End With
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 3)
      For intCol = 1 To objCol.Count
        arrListe(intCol, 1) = .Cells(objCol(intCol), 6)
        arrListe(intCol, 2) = .Cells(objCol(intCol), 3)
        arrListe(intCol, 3) = .Cells(objCol(intCol), 6) & " | " & .Cells(objCol(intCol), 3)
      Next
      Me.ComboBox1.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing

Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub

Private Sub zurück_Click()
    Unload Auswertung
End Sub

Private Sub Druck_Cmd_Click()
    Druck_Cmd.Visible = False
    Auswerten_Cmd.Visible = False
    Me.PrintForm
    Auswerten_Cmd.Visible = True
    Druck_Cmd.Visible = True
End Sub





  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 04.08.2014 12:41:17

Genau sowas habe ich gesucht.

Jetzt nur noch ne Kleinigkeit. Nachdem ich mir das angeschaut habe, möchte ich in der Combobox1 nur einen Ort stehen haben (Mehrfachnennungen ausgeblendet).

In der Combobox2 nur die Uhrzeit (also Startzeitpunkt).

Und in einer zusätzlichen Combobox 3 will ich auswählen können, ob "nein, nur vormittags", "ja, auch nachmittags" und "nein, nur nachmittags".

Die Anpassung in der Listbox bekomme ich selbst hin.


  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 04.08.2014 13:37:37

Hallo Thorsten,


"Kleinigkeit" ist etwas untertrieben. Es sind halt doch etliche Anpassungen nötig, wobei es meistens Vereinfachungen im Code sind.

Gruß
Franz

'Code Userform "Auswertung"
Option Explicit

Private wksData As Worksheet

Private Sub Auswerten_Cmd_Click()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  Dim strOrt As String, strSchulform As String
  Dim varZeitraum As Variant, strStart As String
  On Error GoTo Fehler
  If Me.ComboBox1.ListIndex = -1 Then
    MsgBox "Bitte erst Ort auswählen"
  Else
    With Me.ComboBox1
      strOrt = .List(.ListIndex, 0)
    End With
    
    With Me.ComboBox2
      If .ListIndex >= 0 Then
        strStart = .List(.ListIndex, 0)
      Else
        strStart = "Alle"
      End If
    End With
    
    With Me.ComboBox3
      If .ListIndex < 1 Then
        varZeitraum = "Alle"
      Else
        varZeitraum = 6 + .ListIndex
      End If
    End With
    
    With wksData
      'Liste für Listbox1 gemäß Auswahl in Comboboxen zustammenstellen
      Set objCol = New Collection
      For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
        If strOrt = .Cells(lngZeile, 6).Value Then
          If strStart = "Alle" And varZeitraum = "Alle" Then
            objCol.Add lngZeile
          ElseIf strStart = "Alle" And varZeitraum <> "Alle" Then
            If .Cells(lngZeile, varZeitraum).Text <> "" Then
              objCol.Add lngZeile
            End If
          ElseIf strStart <> "Alle" And varZeitraum = "Alle" Then
            If strStart = Format(.Cells(lngZeile, 11), "h:mm") Then
              objCol.Add lngZeile
            End If
          Else
            If .Cells(lngZeile, varZeitraum).Text <> "" _
              And strStart = Format(.Cells(lngZeile, 11), "h:mm") Then
              objCol.Add lngZeile
            End If
          End If
        End If
      Next
      
      If objCol.Count > 0 Then
        ReDim arrListe(1 To objCol.Count, 1 To 8)
        For intCol = 1 To objCol.Count
          arrListe(intCol, 1) = .Cells(objCol(intCol), 1)
          arrListe(intCol, 2) = .Cells(objCol(intCol), 2)
          arrListe(intCol, 3) = .Cells(objCol(intCol), 3)
          arrListe(intCol, 4) = .Cells(objCol(intCol), 6)
          arrListe(intCol, 5) = .Cells(objCol(intCol), 7)
          arrListe(intCol, 6) = .Cells(objCol(intCol), 8)
          arrListe(intCol, 7) = .Cells(objCol(intCol), 9)
          arrListe(intCol, 8) = Format(.Cells(objCol(intCol), 11), "h:mm")
        Next
        With Me.ListBox1
          .ColumnCount = 8
          .ColumnWidths = "40pt;100pt;80pt;80pt;40Pt;40Pt;40Pt;60Pt"
          .List = arrListe
          Erase arrListe
        End With
      End If
    End With
    Set objCol = Nothing
  End If
  
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With

  
End Sub


Private Sub ComboBox1_Change()

  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  Dim strOrt As String, strSchulform As String
  On Error GoTo Fehler
  If Me.ComboBox1.ListIndex = -1 Then Exit Sub
  
  With Me.ComboBox1
    strOrt = .List(.ListIndex, 0)
  End With
  
  With wksData
    'Liste mit "Startzeitpunkt" für Combobox2 zur Auswahl in Combobox1 zusammenstellen
    Set objCol = New Collection
    lngZeile = 1
    objCol.Add "Alle", Key:="|" & "Alle"
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      If strOrt = .Cells(lngZeile, 6).Value Then
        objCol.Add lngZeile, Key:="|" & Format(.Cells(lngZeile, 11), "hh:mm")
      End If
    Next
    
    Me.ComboBox2.Clear
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 1)
      arrListe(1, 1) = objCol(1)
      For intCol = 2 To objCol.Count
        arrListe(intCol, 1) = Format(.Cells(objCol(intCol), 11), "h:mm")
      Next
      Me.ComboBox2.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub

Private Sub UserForm_activate()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  On Error GoTo Fehler
  Set wksData = Worksheets("Teilnahme")
  With wksData
    'Liste Orte zusammenstellen
    Set objCol = New Collection
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      objCol.Add lngZeile, Key:=.Cells(lngZeile, 6)
    Next
    
    Me.ComboBox1.Clear
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 1)
      For intCol = 1 To objCol.Count
        arrListe(intCol, 1) = .Cells(objCol(intCol), 6)
      Next
      Me.ComboBox1.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing
  
  With Me.ComboBox3
    .AddItem "Alle"
    .AddItem "nein, nur vormittags"
    .AddItem "auch nachmittags"
    .AddItem "nur nachmittags"
  End With
  
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub

Private Sub zurück_Click()
    Unload Auswertung
End Sub

Private Sub Druck_Cmd_Click()
    Druck_Cmd.Visible = False
    Auswerten_Cmd.Visible = False
    Me.PrintForm
    Auswerten_Cmd.Visible = True
    Druck_Cmd.Visible = True
End Sub





  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 04.08.2014 13:53:09

Private Sub UserForm_activate()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  On Error GoTo Fehler
  Set wksData = Worksheets("Teilnahme")
  With wksData
    'Liste Orte zusammenstellen
    Set objCol = New Collection
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      objCol.Add lngZeile, Key:=.Cells(lngZeile, 6)
    Next
    
    Me.ComboBox1.Clear
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 1)
      For intCol = 1 To objCol.Count
        arrListe(intCol, 1) = .Cells(objCol(intCol), 6)
      Next
      Me.ComboBox1.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing
  
  With Me.ComboBox3
    .AddItem "Alle"
    .AddItem "nein, nur vormittags"
    .AddItem "auch nachmittags"
    .AddItem "nur nachmittags"
  End With
  
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub
In der fettgedruckten Zeile kommt ein Fehler.

Laufzeitfehler 457
Dieser Schlüssel ist bereits einem Element dieser Auflistung zugeordnet.



  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 04.08.2014 16:52:22

Hallo Thorsten,

eigentlich kann ich den Fehler nicht nachvollziehen, denn für diese Fehler-Nr. ist eine explizite Fehlerbehandlung vorhanden.

Es könnte aber Probleme mit leeren Zellen in der Spalte "Ort" geben. Deshalb die nachfolgende Anpassung.

Gruß
Franz

Private Sub UserForm_activate()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  On Error GoTo Fehler
  Set wksData = Worksheets("Teilnahme")
  With wksData
    'Liste Orte zusammenstellen
    Set objCol = New Collection
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
        If .Cells(lngZeile, 6) <> "" Then
          objCol.Add lngZeile, Key:=.Cells(lngZeile, 6)
        Else
          objCol.Add lngZeile, Key:="|||"
        End If
    Next
    
    Me.ComboBox1.Clear
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 1)
      For intCol = 1 To objCol.Count
          arrListe(intCol, 1) = .Cells(objCol(intCol), 6)
      Next
      Me.ComboBox1.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing
  
  With Me.ComboBox3
    .Clear
    .AddItem "Alle"
    .AddItem "nein, nur vormittags"
    .AddItem "auch nachmittags"
    .AddItem "nur nachmittags"
  End With
  
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub



  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 06:43:56

Guten Morgen.

Kann es vielleicht sein, dass es damit zusammenhängt, dass ich Ort habe, die mit einem Bindestrich verbunden sind?


  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 07:18:35

Zur Komplettierung habe ich mal die gesamte Datenbank ohne Daten hier hinterlassen.

Es gibt Orte die sind mit einem Bindestrich verbunden, genauso wie einige Straßen. Ist die Liste leer funktioniert es. Trage ich aber dort etwas ein, kommt die Fehlermeldung.

Adminpasswort nicht vorhanden.

https://www.herber.de/bbs/user/91889.xls


  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 05.08.2014 08:13:09

Hallo Thorsten,

ich hab es mit allen möglichen Testdaten probiert. Keine Probleme.

Wenn du der Meinung bist, dass das Problem mit den von dir eingetragenen Daten zusammenhängt, dann macht es keinen Sinn, wenn du hier eine Datei ohne Daten hochlädst. WIe soll dann dann jemand die Ursache für die Probleme feststellen?

Ansonsten im Userformcode in der Activate-Prozedur einen Haltepunkt setzen und mit F8 den Code Schrittweise fortsetzen, bis der Fehler auftritt. Dann kann man nach der Ursache forschen.

Gruß
Franz


  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 08:29:47

Problem ist, dass die Dateien sehr viele Nutzerdaten enthält.

Ich schau mir das mal an.

Falls nicht komme ich darauf zurück.


  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 08:38:21

Fehler gefunden.

Also es liegt daran, dass keine Orte doppelt vorhanden sein können.

Gebe ich zweimal den selben Ort in die Liste ein, dann kommt diese Fehlermeldung.

Könnte Dir das helfen?


  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 05.08.2014 09:37:12

Hallo Thorsten,

relevant sind hier doch nur das Userform "Auswertung" und das Tabellenblatt "Teilnahme" alles andere kannst du Leerlassen. Im Blatt "Teilnahme" dürften ja nicht wirklich personenbezogene Daten oder Betriebsgeheimnisse stehen - ansonsten Daten sinnvoll anonymisieren.

Doppelte Ortsnamen können eigentlich nicht die Ursache sein.
Diese werden durch die von mir integrierte Fehlerbehandlung abgefangen. Wenn du hier meinen Code 1:1 übernommen hast, dann funktioniert das auch. Schließlich verwende ich diese Methode schon sehr lange (seit MS Office 97) mit Erfolg. Nach meiner Einschätzung hast du da irgendetwas angepasst/weggelassen, so dass Fehler 457 jetzt zu einem Abbruch führt.


  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 09:43:20

Hier nochmal eine Datei, in der bei mir der Fehler kommt.

https://www.herber.de/bbs/user/91897.xls


  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 05.08.2014 13:03:55

Hallo Thorsten,

bei mir unter Excel 2010 tritt in deiner Datei kein Fehler auf, die Orts-Liste wird korrekt angezeigt.

Ich hab nochmals 2 kleine Anpassungen eingebaut.
Ob es hilft: ???

Gruß
Franz

Private Sub UserForm_activate()
  Dim objCol As Collection, intCol As Integer
  Dim arrListe()
  Dim lngZeile As Long
  On Error GoTo Fehler
  Set wksData = Worksheets("Teilnahme")
  With wksData
    'Liste Orte zusammenstellen
    Set objCol = New Collection
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
        If .Cells(lngZeile, 6) <> "" Then
          objCol.Add lngZeile, Key:="|" & .Cells(lngZeile, 6)   'angepasst
        Else
          objCol.Add lngZeile, Key:="|||"
        End If
    Next
    
    Me.ComboBox1.Clear
    
    If objCol.Count > 0 Then
      ReDim arrListe(1 To objCol.Count, 1 To 1)
      For intCol = 1 To objCol.Count
          arrListe(intCol, 1) = .Cells(objCol(intCol), 6)
      Next
      Me.ComboBox1.List = arrListe
      Erase arrListe
    End If
  End With
  Set objCol = Nothing
  
  With Me.ComboBox3
    .Clear
    .AddItem "Alle"
    .AddItem "nein, nur vormittags"
    .AddItem "auch nachmittags"
    .AddItem "nur nachmittags"
  End With
  
Err.Clear                                                               'neu
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case 457 'doppelter Collection-Keywert
        Resume Next
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub



  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 13:13:10

Also es liegt definitiv am Duplikat von Orten. Sobald ich einen Ort zweimal in der Liste habe, kommt der Fehler. Definitiv.

Habe ich vielleicht in den Eigenschaften der Userform einen Fehler (siehe Beispieldatei oben)?


  

Betrifft: AW: Auswerten/Selektieren von: fcs
Geschrieben am: 05.08.2014 14:54:41

Hallo Thorsten,

wenn ich bei mir keinen Fehler hab, dann kann ich ich ja auch nicht feststellen, was falsch/ungünstig eingestellt ist.

Ich hab jetzt nochmals eine andere Methode eingebaut, um Listen ohne doppelte Einträge zu erzeugen.
Wenn das nicht funktioniert, dann weiss ich nicht mehr weiter.

Gruß
Franz

Private Sub ComboBox1_Change()

  Dim lngZeile As Long
  Dim strOrt As String
  Dim oDic As Object
  
  On Error GoTo Fehler
  If Me.ComboBox1.ListIndex = -1 Then Exit Sub
  
  With Me.ComboBox1
    strOrt = .List(.ListIndex, 0)
  End With
  
  With wksData
    'Liste mit "Startzeitpunkt" für Combobox2 zur Auswahl in Combobox1 zusammenstellen
    lngZeile = 1
    Set oDic = CreateObject("Scripting.Dictionary")
    oDic("Alle") = 0
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      If strOrt = .Cells(lngZeile, 6).Value Then
        oDic(Format(.Cells(lngZeile, 11), "h:mm")) = 0
      End If
    Next
    
    Me.ComboBox2.Clear
    
    If oDic.Count > 0 Then
      Me.ComboBox2.List = oDic.keys
    End If
    Set oDic = Nothing
  End With
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case Else
        MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub

Private Sub UserForm_activate()
  Dim oDic As Object
  Dim lngZeile As Long
  On Error GoTo Fehler
  Set wksData = Worksheets("Teilnahme")
  
  With wksData
    'Liste Orte zusammenstellen
    Set oDic = CreateObject("Scripting.Dictionary")
    For lngZeile = 2 To .Cells(.Rows.Count, 6).End(xlUp).Row
      oDic(.Cells(lngZeile, 6).Text) = 0
    Next
    
    Me.ComboBox1.Clear
    
    If oDic.Count > 0 Then
      Me.ComboBox1.List = oDic.keys
    End If
    Set oDic = Nothing
  End With
  
  With Me.ComboBox3
    .Clear
    .AddItem "Alle"
    .AddItem "nein, nur vormittags"
    .AddItem "auch nachmittags"
    .AddItem "nur nachmittags"
  End With
  
Err.Clear                                                               'neu
Fehler:
  With Err
    Select Case .Number
      Case 0 'alles OK
      Case Else
        MsgBox "fehler-Nr.: " & .Number & vbLf & .Description
    End Select
  End With
End Sub



  

Betrifft: AW: Auswerten/Selektieren von: Thorsten Weckert
Geschrieben am: 05.08.2014 15:00:10

Egal was Du da gemacht hast. Es klappt.
Danke.

Ich hoffe wenn ich nochmal was habe, darf ich auf Dich zurück kommen.