Frage zu einer UserForm

Private Sub cmdClose_Click()
Unload Me
End Sub

Private Sub cmdDirectory_Click()
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = txtDirectory
.Title = "Suche in Dateien Ordnerauswahl"
.ButtonName = "Auswählen"
.InitialView = msoFileDialogViewList
If .Show = -1 Then
strPath = .SelectedItems(1)
If Right(strPath, 1)  "\" Then strPath = strPath & "\"
End If
End With
If Len(strPath) Then
txtDirectory = strPath
Call SetCustProp("SearchPath", strPath)
End If
End Sub

Private Sub cmsSearch_Click()
Dim strfile As String, strFirst As String
Dim objWB As Workbook, rng As Range
Dim lngRow As Long, varRet As Variant, varSearch As Variant, varNum As Variant, varItemS As  _
Variant, varItemN As Variant
If Dir(txtDirectory, vbDirectory)  "" Then
If Right(txtDirectory, 1)  "\" Then txtDirectory = txtDirectory & "\"
If Len(txtName) Then
If Len(txtNumber) Then
With Application
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
End With
varSearch = Split(txtName, ",")
varNum = Split(txtNumber, ",")
lstResult.Clear
strfile = Dir(txtDirectory & "*.xls*", vbNormal)
Do While Len(strfile)
strFirst = ""
Set objWB = Workbooks.Open(txtDirectory & strfile)
With objWB.Sheets("Tabelle1")
For Each varItemS In varSearch
Set rng = .Columns(1).Find(What:=varItemS, LookAt:=xlWhole, LookIn:=xlValues,  _
MatchCase:=False, SearchFormat:=False, After:=.Cells(1, 1))
If Not rng Is Nothing Then
strFirst = rng.Address
Do
lngRow = Int((rng.Row - 5) / 22) * 22 + 6
For Each varItemN In varNum
If IsNumeric(varItemN) Then
varRet = Application.Match(CLng(varItemN), .Rows(lngRow), 0)
If IsNumeric(varRet) Then
If .Cells(rng.Row, varRet) > 0 Then
lstResult.AddItem strfile
lstResult.List(lstResult.ListCount - 1, 1) = varItemS & " / " &  _
varItemN
lstResult.List(lstResult.ListCount - 1, 2) = .Cells(lngRow - 1,  _
varRet)
lstResult.List(lstResult.ListCount - 1, 3) = .Cells(rng.Row, varRet)
lstResult.List(lstResult.ListCount - 1, 4) = txtDirectory & strfile &  _
"|Tabelle1|" & .Cells(rng.Row, varRet).Address
End If
End If
End If
Next
Set rng = .Columns(1).FindNext(rng)
Loop While Not rng Is Nothing And rng.Address  strFirst
End If
Next
.Parent.Close False
End With
strfile = Dir
Loop
If lstResult.ListCount = 0 Then
lstResult.AddItem "Kein Treffer!"
Else
Call SortListBox(lstResult, 0, lstResult.ListCount - 1, 0)
End If
Else
MsgBox "Bitte geben Sie eine Nummer ein!", vbInformation
End If
Else
MsgBox "Bitte geben Sie einen Namen an!", vbInformation
End If
Else
MsgBox "Verzeichnis nicht gefunden!", vbInformation
End If
ErrorHandler:
With Application
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
End With
Set objWB = Nothing
End Sub

Private Sub lstResult_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
With lstResult
If .ListIndex > -1 Then
If .List(.ListIndex, 0)  "Kein Treffer!" Then
Call Workbooks.Open(Split(.List(.ListIndex, 4), "|")(0))
Call Application.GoTo(Sheets(Split(.List(.ListIndex, 4), "|")(1)).Range(Split(.List(. _
ListIndex, 4), "|")(2)), False)
End If
End If
End With
End Sub

Private Sub txtDirectory_Change()
End Sub

Private Sub UserForm_Activate()
txtDirectory = GetCustProp("SearchPath", SEARCH_PATH)
End Sub

Private Sub SortListBox(ByRef TheBox As MSForms.ListBox, LowerBound As Long, UpperBound As Long, _
SortColumn As Byte)
'original by Nepumuk
Dim lngIndex1 As Long, lngIndex2 As Long
Dim vntTemp As Variant, vntBuffer As Variant
Dim bytIndex As Byte
lngIndex1 = LowerBound
lngIndex2 = UpperBound
vntTemp = TheBox.List((LowerBound + UpperBound) \ 2, SortColumn)
Do
Do While TheBox.List(lngIndex1, SortColumn)  lngIndex2
If LowerBound 

Private Function GetCustProp(propName As String, Optional propValue As Variant) As Variant
'  Wert aus Dateieigenschaft auslesen. Wenn nicht vorhanden
'  Anlegen und Optional mit Startwert belegen
Dim propType As MsoDocProperties
If Not IsMissing(propValue) Then
Select Case VarType(propValue)
Case vbString
propType = msoPropertyTypeString
Case vbBoolean
propType = msoPropertyTypeBoolean
Case vbByte, vbInteger, vbLong
propType = msoPropertyTypeNumber
Case vbSingle, vbDouble
propType = msoPropertyTypeFloat
Case vbDate
propType = msoPropertyTypeDate
Case Else
End Select
End If
With ThisWorkbook
On Error GoTo NoName
GetCustProp = .CustomDocumentProperties(propName).Value
Exit Function
NoName:
If Err.Number = 5 Then
Err.Clear
.CustomDocumentProperties.Add _
Name:=propName, _
LinkToContent:=False, _
Type:=propType, _
Value:=propValue
GetCustProp = propValue
End If
End With
End Function

Private Function SetCustProp(propName As String, propValue As Variant)
'  Wert in Dateieigenschaft schreiben. Wenn nicht vorhanden
'  Anlegen und Wert eintragen
Dim propType As MsoDocProperties
Select Case VarType(propValue)
Case vbString
propType = msoPropertyTypeString
Case vbBoolean
propType = msoPropertyTypeBoolean
Case vbByte, vbInteger, vbLong
propType = msoPropertyTypeNumber
Case vbSingle, vbDouble
propType = msoPropertyTypeFloat
Case vbDate
propType = msoPropertyTypeDate
Case Else
End Select
With ThisWorkbook
On Error GoTo NoName
.CustomDocumentProperties(propName).Value = propValue
Exit Function
NoName:
If Err.Number = 5 Then
Err.Clear
.CustomDocumentProperties.Add _
Name:=propName, _
LinkToContent:=False, _
Type:=propType, _
Value:=propValue
End If
End With
End Function