Kann mir jemand bei folgendem kleinen Problem helfen?
ICH MÖCHTE GERN JEWEILS DEN TEXT ZWEI ZELLEN (SPALTEN) LINKS VON DER GEFUNDENEN ZELLE ALS VARIABLE "Akte$" AUSLESEN LASSEN UND NACHHER UNTEN BEI DEN SUCHERGEBNISSEN ANZEIGEN LASSEN.
Danke für Eure Hilfe!
M.
Option Base 1
Option Compare Text
Sub Suchen_und_anzeigen()
Dim Meldung As Byte
Dim Suchen As Variant
Dim n%, x%, xZelle%, yZelle%
Dim Bereich$, Text$, Adresse$(), Akte$()
Bereich = "A1:T200"
'Suchbegriff eingeben
Suchen = InputBox("Bitte den zu suchenden Begriff eingeben." & vbCrLf & _
"ENTER ohne Wert = Abbruch", "S U C H M O D U S")
If Suchen = "" Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
' letzte Zelle im Bereich ermitteln
With ActiveSheet.Range(Bereich)
xZelle = .Columns(.Columns.Count).Column
yZelle = .Rows(.Rows.Count).Row
End With
' Eigentlicher Suchvorgang (in allen Tabellenblättern)
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)
' ICH MÖCHTE HIER GERN DEN TEXT 2 ZELLEN LINKS VON DER GEFUNDENEN ZELLE als Variable "Akte$"
' AUSLESEN LASSEN UND NACHHER UNTEN BEI DEN SUCHERGEBNISSEN ANZEIGEN LASSEN.
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
For n = 1 To x - 1
Text = Text & " Zelle " & Adresse(n) & vbCrLf
Next n
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
' Die Anzahl der gefundenen Werte ist (x - 1), wenn keiner
' gefunden wurde dann ist x = 1
Select Case x
Case 1
Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
vbOKOnly, "G E F U N D E N E W E R T E")
Case 2
ActiveSheet.Select
ActiveSheet.Range(Adresse(1)).Select
Meldung = MsgBox("Es wurde eine Übereinstimmung in" & vbCrLf & _
Text & vbCrLf & "gefunden", vbOKOnly, "G E F U N D E N E W E R T E")
Exit Sub
Case Else
For n = 1 To x - 1
ActiveSheet.Select
ActiveSheet.Range(Adresse(n)).Select
Meldung = MsgBox("Drücken Sie JA, um den nächsten gefundenen " & _
"Wert zu sehen" & vbCrLf & "Insgesamt gibt es " & (x - 1) & _
" Übereinstimmungen!" & vbCrLf & Text, vbYesNo, "G E F U N D E N E W E R T E")
If Meldung = vbNo Then Exit Sub
Next n
End Select
End Sub