Suchen markrieren kopieren weitersuchen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
InputBox MsgBox
Bild

Betrifft: Suchen markrieren kopieren weitersuchen
von: Thomas
Geschrieben am: 07.11.2003 17:33:04

Hallo Forum!

Ich möchte in meiner Tabelle über alle Zeilen und Spalten einen Begriff suchen (Zahl oder Text). Sofern der Begriff gefunden wird soll die Zeile markiert werden und mit einer Msgbox gefragt werden ob die Zeile kopiert werden soll. Wenn ja zeile in Tabelle 2 kopieren. Danach Msgbox ob weitergesucht werden soll.
usw. gefunden kopieren.........

Kann mir da jemand helfen?

LG
Thomas

Bild


Betrifft: AW: Suchen markrieren kopieren weitersuchen
von: Nepumuk
Geschrieben am: 07.11.2003 20:32:13

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


Bild


Betrifft: AW: Suchen markrieren kopieren weitersuchen
von: Beni
Geschrieben am: 07.11.2003 20:56:04

Hallo Thomas,
ich habe Dir ein Beispiel angefügt.
Gruss Beni

https://www.herber.de/bbs/user/1801.xls


Sub Daten_kopieren()
Sheets(1).Select
c = Cells(1, 256).End(xlToLeft).Column
r = Cells(65536, 1).End(xlUp).Row
Titel = "InputBox"
Mldg = "Suchbegriff eingeben"
Wert = InputBox(Mldg, Titel)
If Wert = "" Then Exit Sub
For i = 1 To r
With Sheets(1).Rows(i)
Set w = .Find(Wert, LookIn:=xlValues, LookAt:=xlWhole)
If Not w Is Nothing Then
vorhanden = 1
Range(Cells(i, 1), Cells(i, c)).Select
Status = MsgBox("Zeile_kopieren?", _
       vbQuestion + vbYesNo, _
       "Einträge löschen")
 Select Case Status
  Case vbYes
   With Sheets(2)
 Dim lRow As Long
      lRow = .Cells(65536, 1).End(xlUp).Row + 1
    For a = 1 To c
      .Cells(lRow, a).Value = Cells(i, a).Value
    Next a
   End With
Case vbNo
 End Select
 End If
End With
Next i
If vorhanden < 1 Then MsgBox "Suchbegriff nicht vorhanden"
End Sub



Bild

Beiträge aus den Excel-Beispielen zum Thema " Suchen markrieren kopieren weitersuchen"