Wert aus aktiver Zelle in InputBox übertragen
13.12.2008 07:44:52
Axel
Ich habe hier eine Suchfunfunktion mit InputBox.
Ist es irgendwie möglich beim Start des Makros den Wert der aktiven Zelle in die Inputbox automatisch zu übertragen, so das ich ihn nicht selbst hineintippen/kopieren brauch?
Die Suche soll trotzdem über die Inputbox laufen, da ich den Wert (meistens nur Text) manchmal doch noch abändern muss, sonst könnte man sich die Inputbox ja auch komplett sparen ;)
Mfg Axel
hier mal die ganze Funktion:
Sub Suche()
Dim Meldung As Byte
Dim Suchen As Variant
Dim n%, x%, xZelle%, yZelle%
Dim Bereich$, Text$, Adresse$(), Akte$()
Bereich = "D20:D10000"
'Suchbegriff eingeben
Suchen = InputBox("Bitte den zu suchenden Begriff eingeben." & vbCrLf & _
"ENTER ohne Wert = Abbruch", "Suche")
If Suchen = "" Then Exit Sub
' letzte Zelle im Bereich ermitteln
With ActiveSheet.Range(Bereich)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
' Eigentlicher Suchvorgang
x = 1
With ActiveSheet.Range(Bereich)
Set c = .Find(Suchen, After:=Cells(yZelle, xZelle), LookIn:=xlValues)
If Not c Is Nothing Then
ErsteAdresse = c.Address
Do
ReDim Preserve Adresse(x)
Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
Set c = .FindNext(c)
x = x + 1
Loop While Not c Is Nothing And c.Address ErsteAdresse
End If
End With
' Anzeige der Suchergebnisse
Text = vbCrLf
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Leider nichts gefunden", _
vbOKOnly, "Suche")
Case 2
ActiveSheet.Select
ActiveSheet.Range(Adresse(1)).Select
ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
ActiveWindow.SmallScroll Up:=2
Exit Sub
Case Else
For n = 1 To x - 1
ActiveSheet.Select
ActiveSheet.Range(Adresse(n)).Select
ActiveWindow.ScrollRow = ActiveWindow.ActiveCell.Row
ActiveWindow.SmallScroll Up:=2
Meldung = MsgBox("Suchergebnis " & n & _
" von " & (x - 1) & _
". Weitersuchen?", vbYesNo, "Suche")
If Meldung = vbNo Then Exit Sub
Next n
End Select
End Sub