Hallöchen...
27.03.2018 10:31:15
Peter(silie)
hier eine Mappe mit Userform und Modul zum Suchen: https://www.herber.de/bbs/user/120693.xlsm
(Suche einfach nach "a")
Klicke auf das Pfeil Symbol um einen Suchverlauf anzeigen zu lassen.
Bei Doppelklick auf einen Eintrag springt er direkt dorthin.
Er durchläuft nicht automatisch alle Tabellen, du musst die Tabelle auswählen wo er suchen soll.
Es kann Optional eine von 5000 Spalten ausgewählt werden.
Wird eine Ausgewählt, dann sucht er nur in dieser Spalte.
Um alle zu durchsuchen einfach den Leeren Eintrag ganz oben auswählen.
User Eingaben sind bei den Comboboxen gesperrt.
Hier der Code des Moduls "SearchAgent":
Option Explicit
Public Type SearchSuccess
IsSuccess As Boolean 'if search found something
SearchedValue As String 'the searched value
FoundValue As String 'the found value
InTable As String 'the table with the value
InRange As String 'the range with the value
End Type
Private shTbl As Worksheet 'Table in which we Search
Private sValue As String 'The Value we search for
Private fstAddrs As String 'The first Address we found
Private lstAddrs As String 'The last/latest Address we found
Private bCaseSen As Boolean 'If we want to search Case Sensitive
Private bMatchWh As Boolean 'If we want to Match the Whole Word
Private bWhTable As Boolean 'If we want to search the whole Sheet
Private luColumn As String 'The User defined Column to look in
'Our LookUp Table
'Get AND Set
Public Property Get LookUpTable() As Worksheet
Set LookUpTable = shTbl
End Property
Public Property Set LookUpTable(ByRef this_ As Worksheet)
Set shTbl = this_
End Property
'the user defined value to search for
Public Property Let SearchValue(ByVal value_ As Variant)
sValue = CStr(value_)
End Property
'if the search object is casesensitiv
Public Property Let CaseSensitive(ByVal value_ As Boolean)
bCaseSen = value_
End Property
'if the whole word should be matched
Public Property Let MatchWholeWord(ByVal value_ As Boolean)
bMatchWh = value_
End Property
'if the LookUp is supposed to be in the whole sheet
Public Property Let WholeWorksheet(ByVal value_ As Boolean)
bWhTable = value_
End Property
Public Property Let LookUpColumn(ByVal value_ As String)
luColumn = value_
End Property
Public Sub OpenForm()
frm_FindValue.Show
End Sub
'Reset the addresses and the table to look in
'no need to reset more
Public Sub Reset()
Set shTbl = Nothing
fstAddrs = vbNullString
lstAddrs = vbNullString
End Sub
Public Function GetSearch() As SearchSuccess
Dim sDef As Range
Dim sObj As Range
'if there is no table go out
If shTbl Is Nothing Then
GetSearch.IsSuccess = False
Exit Function
End If
With shTbl
'First we need the overall range to look in
'if the user selected no specific column
'then the range is the usedrange
'else its the user defined Column
If bWhTable Then
Set sDef = GetUsedRange
Else
If luColumn vbNullString Then
Set sDef = .Range(luColumn & ":" & luColumn)
Else
Set sDef = GetUsedRange
End If
End If
'If the range failed then go out
If sDef Is Nothing Then
GetSearch.IsSuccess = False
Exit Function
End If
'now get the Search Range Object
Set sObj = GetSearchObject(sDef)
'if the search was a success then
If Not sObj Is Nothing Then
'if the search isnt the first search
If sObj.Address fstAddrs Then
'if this was the first search
If fstAddrs = vbNullString Then
fstAddrs = sObj.Address
End If
'set the last address to be this address
lstAddrs = sObj.Address
'fill the SearchSuccess Type
GetSearch.IsSuccess = True
GetSearch.SearchedValue = sValue
GetSearch.FoundValue = sObj.Value
GetSearch.InRange = sObj.Address
GetSearch.InTable = shTbl.Name
End If
Else
GetSearch.IsSuccess = False
End If
End With
End Function
'this will return a range object that searched a range for a specific value
Private Function GetSearchObject(ByRef DefinedSearchRange As Range) As Range
Dim soRG As Range
'if the range is bad go out
If DefinedSearchRange Is Nothing Then Exit Function
With DefinedSearchRange
'If the last address is not nothing
If lstAddrs vbNullString Then
'if match whole word
If bMatchWh Then
'this will find a value after the last found value
Set soRG = .Find(What:=sValue, After:=.Range(lstAddrs), _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=bCaseSen)
Else
Set soRG = .Find(What:=sValue, After:=.Range(lstAddrs), _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=bCaseSen)
End If
Else
'if match whole word
If bMatchWh Then
'this will find a value without looking at previous
Set soRG = .Find(What:=sValue, _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=bCaseSen)
Else
Set soRG = .Find(What:=sValue, _
LookIn:=xlValues, LookAt:=xlPart, _
SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=bCaseSen)
End If
End If
End With
Set GetSearchObject = soRG
End Function
'This Function will return the actual UsedRange
'it looks for any value in any row and any value in any column
'if this thing is still A1 then the sheet is really empty
'it uses the cells.find method
'might look ugly but works fine
Private Function GetUsedRange() As Range
With shTbl
Set GetUsedRange = .Range("a1").Resize( _
.Cells.Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row, _
.Cells.Find(What:="*", SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Column)
End With
End Function
hier der Userform Code:
Option Explicit
Private bClpsd As Boolean 'tells if the UserForm is collapsed or not
'Cloeses the form
Private Sub btn_Abort_Click()
Unload Me
End Sub
'clears the Listbox
Private Sub btn_Clear_Click()
Me.ListBox1.Clear
End Sub
'Executes the search
Private Sub btn_ExecuteAgain_Click()
'This will contain the found data
Dim vItems As SearchAgent.SearchSuccess
'if the search is nothing go out
If Me.tb_SearchValue.Value = vbNullString Then Exit Sub
'give the value to the SearchAgent
SearchAgent.SearchValue = Me.tb_SearchValue.Value
'if there is a table selected
If Me.cb_SearchIn.Value vbNullString Then
Set SearchAgent.LookUpTable = ThisWorkbook.Sheets(Me.cb_SearchIn.Value)
End If
'if no specific column is to be searched
If Me.cb_SearchColumn.Value = vbNullString Then
SearchAgent.WholeWorksheet = True
Else
'give the column to the agent
SearchAgent.LookUpColumn = Me.cb_SearchColumn.Value
SearchAgent.WholeWorksheet = False
End If
'Try the search
vItems = SearchAgent.GetSearch
'if the search was successfull
If vItems.IsSuccess Then
'Add alle the items
With Me.ListBox1
.AddItem vItems.FoundValue, 0
.List(0, 1) = vItems.SearchedValue
.List(0, 2) = vItems.InRange
.List(0, 3) = vItems.InTable
End With
Else
'Display that the search wasnt successfull and reset the agent
MsgBox "Begriff konnte nicht gefunden werden!" & vbCrLf & _
"Die Suche wurde zurückgesetzt", vbExclamation, "Suche erfolglos"
SearchAgent.Reset
End If
End Sub
Private Sub cb_SearchColumn_Change()
With Me.cb_SearchColumn
If .Value = vbNullString Then
SearchAgent.WholeWorksheet = True
Else
SearchAgent.LookUpColumn = .Value
SearchAgent.WholeWorksheet = False
End If
End With
End Sub
Private Sub ck_Spelling_Click()
SearchAgent.CaseSensitive = ck_Spelling.Value
End Sub
Private Sub ck_WholeWord_Click()
SearchAgent.MatchWholeWord = ck_WholeWord.Value
End Sub
Private Sub lbl_btn_CollapseExpand_Click()
If bClpsd Then
bClpsd = False
Me.Height = 319.5
Me.lbl_btn_CollapseExpand.Caption = "5"
Else
bClpsd = True
Me.Height = 164.25
Me.lbl_btn_CollapseExpand.Caption = "6"
End If
End Sub
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Cancel = True
With ListBox1
If IsNull(.List) Then Exit Sub
If Not IsNull(.List(.ListIndex, 0)) Then
Dim ws As Object
Set ws = ThisWorkbook.Sheets(.List(.ListIndex, 3))
ws.Activate
ws.Range(.List(.ListIndex, 2)).Select
End If
End With
End Sub
Private Sub UserForm_Initialize()
bClpsd = True
Me.cb_SearchIn.List = Split(GetTables, ";")
Me.cb_SearchIn.Value = Me.cb_SearchIn.List(0, 0)
Me.cb_SearchColumn.List = Split(GetColumns, ";")
End Sub
Private Function GetTables() As String
Dim ws As Worksheet
For Each ws In ThisWorkbook.Sheets
GetTables = GetTables & ";" & ws.Name
Next ws
GetTables = Right(GetTables, Len(GetTables) - 1)
End Function
Private Function GetColumns() As String
Dim n As Long
Dim c As Byte
Dim s As String
Dim i As Long
Dim t As String
For i = 1 To 5000
n = i
s = vbNullString
Do
c = ((n - 1) Mod 26)
s = Chr(c + 65) & s
n = (n - c) \ 26
Loop While n > 0
t = t & ";" & s
Next i
GetColumns = t
End Function