AW: Suchen
05.09.2006 15:40:33
Peter
Hallo ticonhh
so könnte es gehen: anpassen musst du allerdings ein wenig.
Sub SuchenInAndererDatei()
Dim objWb As Workbook
Dim objSh As Worksheet
Dim strFile As String
Dim SuWert As String
Dim lLetzte As Long
Dim lZeile As Long
Dim firstAdr As String
Dim Zelle As Range
Dim SuAdr As String
On Error GoTo ErrExit
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.Cursor = xlWait
End With
strFile = "C:\TestDaten.xls" ' hier anpassen!!!
If Not ThisWorkbook Is ActiveWorkbook Then ThisWorkbook.Activate
Set objSh = ActiveSheet
Set objWb = Workbooks.Open(strFile)
objSh.Unprotect Password:="Test" ' Passwort anpassen!!!
Start_InpBox:
SuAdr = ""
SuWert = Application.InputBox(prompt:=" Bitte einen Suchbegriff eingeben!", _
Title:=" Suche", Type:=2)
If SuWert = "Falsch" Then Exit
Sub ' Abbrechen wurde angeklickt
If SuWert = "" Or SuWert = " " Then ' es wurde nichts eingegeben
MsgBox "Ohne Eingabe eines Suchbegiffes kann das Makro nicht suchen.", _
64, " fehlende Eingabe."
GoTo Start_InpBox
End If
With objWb.Sheets(1)
lLetzte = Cells(65536, 1).End(xlUp).Row
Set Zelle = Range("A1:A" & lLetzte).Find(SuWert, LookIn:=xlValues, LookAt:=xlWhole)
If Not Zelle Is Nothing Then
firstAdr = Zelle.Address
Do
If SuAdr = "" Then
SuAdr = Zelle.Address
Else
SuAdr = SuAdr & ", " & Zelle.Address
End If
Set Zelle = Range("A1:A" & lLetzte).FindNext(Zelle)
Loop While Not Zelle Is Nothing And Zelle.Address <> firstAdr
End If
If firstAdr = "" Then
MsgBox "Der Suchbegiff " & SuWert & " wurde nicht gefunden.", _
64, " Suchbegriff ist nicht vorhanden."
Else
objSh.Range(firstAdr).Offset(0, 1).Value = SuAdr
End If
End With
objSh.Protect Password:="Test" ' Passwort anpassen!!!
objWb.Close False
ErrExit:
If Err.Number > 0 Then
MsgBox Err.Number & vbLf & Err.Description, , "Fehler"
Err.Clear
End If
Set objWb = Nothing
Set objSh = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.Cursor = xlDefault
End With
End Sub
Viele Grüße Peter
Eine kurze Nachricht, ob es läuft, wäre nett - danke.