erweiterte Suchfunktion in Excel
18.06.2014 11:12:19
Stefan
Diese hat folgendem Code
Sub suchen()
Dim rngFind As Range
Dim strTitel As String
'suchdialog kreieren
strTitel = InputBox("Suche nach:", "Suchbegriff eingeben", , 5, 5)
'zu durchsuchenden spaltenumfang angeben
Set rngFind = Columns("A:H").Find(strTitel, LookIn:=xlFormulas)
'zur stelle springen oder message ausgeben
If Not rngFind Is Nothing Then
rngFind.Select
Else
MsgBox "Es wurde nichts gefunden"
End If
End Sub jetzt muss ich es eigentlich nur schaffen das er in einem anderen Tabellenblatt in bestimmten Zelle sucht. und dann wie in diesem Code eigentlich alles kopiert und altes löscht. Das muss irgendwie in die Suchfunktion mit eingebaut werden. Leider übersteigt es gerade etwas meine Fähigkeiten. Um eure Hilfe wäre ich sehr dankbar.
Hier ein Link zu meinem eigentlch Excel Dokument
https://www.dropbox.com/s/5ne0vmaypt7aox7/DP-Beta5.xlsm
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
Dim intRow, lngSpalte
If Target.Address = "$A$2" Then
Cells(2, 2) = "Nichts Ausgewählt"
ElseIf Target.Address = "$B$2" Then
If Cells(2, 2) "Nichts Ausgewählt" Then
With Sheets("Auswahl")
intRow = 2
'Zeilen hochzählen, bis zur 1. leeren Zeile in E:M
Do
'prüfen, ob Zellen in Spalten E bis M der Zeile leer sind
If Application.WorksheetFunction.CountA(.Range(.Cells(intRow, 5), _
.Cells(intRow, 14))) = 0 Then
If intRow > 2 Then
Application.EnableEvents = False
'Inhalte und Formate im Bereich E2:Mxxx löschen
.Range(.Cells(2, 5), .Cells(intRow - 1, 14)).Clear
Application.EnableEvents = True
End If
Exit Do
End If
intRow = intRow + 1
Loop
End With
For intRow = 1 To 300
If Target.Value = Worksheets("DP").Cells(intRow, 1).Value Then
With Sheets("DP")
If .Cells(intRow, 1).MergeCells = True Then 'Zellen in Spalte A _
sind verbunden
.Range(.Cells(intRow, 2), .Cells(intRow + _
.Cells(intRow, 1).MergeArea.Rows.Count - 1, 10)).Copy
Else
.Range(.Cells(intRow, 2), .Cells(intRow, 10)).Copy
End If
End With
With Sheets("Auswahl")
Application.EnableEvents = False
.Cells(Target.Row, 5).PasteSpecial Paste:=xlPasteFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.Cells(Target.Row, 5).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Application.EnableEvents = True
End With
Exit For
End If
Next intRow
End If
End If
End Sub