AW: Suchen markrieren kopieren weitersuchen
07.11.2003 20:32:13
Nepumuk
Hallo Thomas,
ich habe mit den wenigen Informationen die du über den Tabellenaufbau preis gibst ein Programm auf Verdacht geschrieben. Beim suchen berücksichtigt es nur ganze Werte. D.h. "abcd" wird nicht in "abcde" gefunden. Des weitern wird Groß- und Kleinschreibung unterschieden. Beim kopieren wird in Tabelle 2 nachgeschaut, welche Zeile in Spalte a nicht belegt ist. In diese Zeile wird dann kopiert.
Option Explicit
Public Sub suchen()
Dim myRange As Range, strSuchbegriff As String, strAdresse As String
Dim lngZeile As Long, intSpalte As Integer, myWs As Worksheet
Set myWs = Worksheets(2)
strSuchbegriff = InputBox("Suchbegriff eingeben", "Eingabe")
If Trim(strSuchbegriff) <> "" Then
With Worksheets(1).Cells
Set myRange = .Find(What:=strSuchbegriff, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not myRange Is Nothing Then
strAdresse = myRange.Address
Do
If myRange.Column + 5 < 256 Then intSpalte = myRange.Column + 5 Else intSpalte = myRange.Column
If myRange.Row - 5 > 0 Then lngZeile = myRange.Row - 5 Else lngZeile = myRange.Row
ActiveWindow.ScrollColumn = intSpalte
ActiveWindow.ScrollRow = lngZeile
myRange.Select
Select Case MsgBox("Diese Zeile kopieren?", 35, "Abfrage")
Case 2: Exit Sub
Case 6: myWs.Range(myWs.Cells(myWs.Cells(65536, 1).End(xlUp).Row + 1, 1), _
myWs.Cells(myWs.Cells(65536, 1).End(xlUp).Row + 1, 256)) = _
Range(Cells(myRange.Row, 1), Cells(myRange.Row, 256)).Value
End Select
If MsgBox("Weitere Einträgen suchen?", 36, "Abfrage") = 7 Then Exit Sub
Set myRange = .FindNext(myRange)
Loop While Not myRange Is Nothing And myRange.Address <> strAdresse
MsgBox "Keine weiteren Einträge gefunden.", 64, "Information"
Else
MsgBox "Suchbegriff nicht gefunden.", 48, "Hinweis"
End If
End With
End If
End Sub
Code eingefügt mit: Excel Code Jeanie
Gruß
Nepumuk