Format aus Spalte nicht identisch mit Textfeld

Private Sub Grund()
' Variablendeklaration
Dim intCounter As Integer
Dim shSource As Worksheet
Dim lngRow As Long
Dim wb As Workbook
Dim sport As String
Dim fd As FileDialog
Dim vrtSelectedItem As Variant
Set shSource = Sheets("Grunddaten")
For intCounter = 1 To 18
'Wenn eine Auswahl erfolgte, dann
If Controls("cbbKriterium" & intCounter).ListIndex  -1 Then
'Kriterium festlegen
Select Case Controls("cbbKriterium" & intCounter).Value
Case "(Alle)"
shSource.Range("A1").Autofilter Field:=intCounter '(Alle) anzeigen
Case "(Leere)", ""
shSource.Range("A1").Autofilter Field:=intCounter, Criteria1:="=" '(Leere) filtern
Case "(NichtLeere)"
shSource.Range("A1").Autofilter Field:=intCounter, Criteria1:="" '(Nichtleere) _
filtern
Case Else
With Controls("cbbKriterium" & intCounter)
If intCounter = 3 Then
shSource.Range("A1").Autofilter Field:=intCounter, _
Criteria1:=CDate(.Value)
Else
If IsNumeric(.Value) Then
If IsDate(.Value) Then
shSource.Range("A1").Autofilter Field:=intCounter, _
Criteria1:=CDate(.Value)
Else
shSource.Range("A1").Autofilter Field:=intCounter, _
Criteria1:=CDbl(.Value)
End If
Else
shSource.Range("A1").Autofilter Field:=intCounter, _
Criteria1:=.Value
End If
End If
End With
End Select
End If
Next intCounter
' Alle sichtbaren Zellen kopieren
shSource.Range("A1").CurrentRegion.Copy
' Neues Arbeitsblatt hinzufügen
Worksheets.Add After:=Worksheets(Worksheets.Count)
ActiveSheet.Paste
' Autofilter ausschalten
shSource.Range("A1").Autofilter
' Kopiermodus ausschalten
Application.CutCopyMode = False
Range("A1").Select
'wb.Activate
'Rows("1:1").Select
' Dialog beenden
Unload Me
Set fd = Nothing
End Sub

Private Sub LabelsKrit()
Dim intCounter As Long
For intCounter = 1 To 18
'Text für Combobox-Labels einlesen aus Zeile 1 des Blatts Grunddaten
Controls("Label" & intCounter).Caption = wksGrund.Cells(1, intCounter)
Next intCounter
End Sub

Private Sub KritGrund()
Dim intCounter As Long
'Daten aus den 18 Spalten für die Kriterien Komboboxen auslesen
For intCounter = 1 To 18
Select Case intCounter
Case 1, 4 'Spalten mit Text
Call Listboxfuellen(objList:=Controls("cbbKriterium" & intCounter), _
wks:=wksGrund, Spalte:=intCounter, StartZeile:=2, intType:=2, _
arrImmer:=Array("(Alle)", "(Leere)", "(NichtLeere)"))
Case 2 'Spalten mit Zahlen
Call Listboxfuellen(objList:=Controls("cbbKriterium" & intCounter), _
wks:=wksGrund, Spalte:=intCounter, StartZeile:=2, intType:=1, _
arrImmer:=Array("(Alle)", "(Leere)", "(NichtLeere)"))
Case 3 'Spalten mit Datum
Call Listboxfuellen(objList:=Controls("cbbKriterium" & intCounter), _
wks:=wksGrund, Spalte:=intCounter, StartZeile:=2, intType:=3, _
arrImmer:=Array("(Alle)", "(Leere)", "(NichtLeere)"))
Case Else 'Spalten ohne Nummer in case werden nach Inhaltstyp ausgewertet
Call Listboxfuellen(objList:=Controls("cbbKriterium" & intCounter), _
wks:=wksGrund, Spalte:=intCounter, StartZeile:=2, _
arrImmer:=Array("(Alle)", "(Leere)", "(NichtLeere)"))
End Select
Next
End Sub

Private Sub Listboxfuellen(objList As Object, wks As Worksheet, ByVal Spalte As Long, _
Optional StartZeile As Long = 1, Optional ZeileLast As Long = 0, _
Optional intType As Integer = 1, Optional arrImmer)
'Auswahlliste für Listbox oder Combobox erstellen
'objList = Listbox oder Combobox, die mit Daten gefüllt werden soll
'wks = tabellenblatt mit den Auswahldaten
'Spalte = Spalte aus der Listendaten ausgelesen werden sollen
'StartZeile = Zeile ab der Daten eingelesen werden sollen
'ZeileLast = Letzte Zeile die eingelsen werden soll, wenn = 0 dann bis letzte Zelle mit  _
Inhalt
'intType = Werte typ in Spalte 1 = Zahl, 2 = Text, 3 = Datum
'arrImmer = Optionales Array mit Werten die immer in der Auswahlliste angezeigt werden sollen
Dim lngZeile As Long, strWert As String, bolItemAdd As Boolean
Dim strKey
Dim objCollection As Collection
Const strBlank = "XYZ999ZXY" 'Schlüsselwert für Leere Zellen in Liste
On Error GoTo Fehler
Set objCollection = New Collection
objList.Clear 'vorhandene Liste entfernen
'Werte die immer in die Auswahlliste aufgenommen werden sollen
If IsArray(arrImmer) Then
For lngZeile = LBound(arrImmer) To UBound(arrImmer)
strWert = arrImmer(lngZeile)
If strWert = "" Then
strKey = strBlank
Else
strKey = strWert
End If
bolItemAdd = True
objCollection.Add Item:=strWert, key:=strKey
If bolItemAdd = True Then
objList.AddItem strWert
End If
Next
End If
With wks
If ZeileLast = 0 Then
'letzte Datenzeile in Spalte ermitteln
ZeileLast = .Cells(.Rows.Count, Spalte).End(xlUp).Row
End If
'Werte aus Spalte ohne Doppelte zur Auswahlliste hinzufügen
For lngZeile = StartZeile To ZeileLast
'Leere Zellen überspringen
If Not IsEmpty(.Cells(lngZeile, Spalte)) Then
Select Case intType
Case 1 'Zahlen
If IsNumeric(.Cells(lngZeile, Spalte)) Then
strWert = CStr(.Cells(lngZeile, Spalte))
Else
strWert = .Cells(lngZeile, Spalte).Value
End If
Case 2 'text
strWert = .Cells(lngZeile, Spalte).Text
Case 3 'Datum
strWert = .Cells(lngZeile, Spalte).Text
Case Else 'gemischte Auswertung
If IsNumeric(.Cells(lngZeile, Spalte)) Then
If IsDate(.Cells(lngZeile, Spalte)) Then
strWert = .Cells(lngZeile, Spalte).Text
Else
strWert = CStr(.Cells(lngZeile, Spalte))
End If
Else
strWert = .Cells(lngZeile, Spalte).Value
End If
End Select
If strWert = "" Then
strKey = strBlank
Else
strKey = strWert
End If
bolItemAdd = True
objCollection.Add Item:=strWert, key:=strKey
If bolItemAdd = True Then
objList.AddItem strWert
End If
End If
Next
End With
Fehler:
With Err
If .Number  0 Then
Select Case .Number
Case 457 'objCollection.Add ergibt Fehler, weil doppelter Eintrag
bolItemAdd = False
Resume Next
Case Else
MsgBox "Fehler: " & .Number & vbLf & .Description
End Select
End If
End With
End Sub