Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1232to1236
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Suchen - Kopieren - Einfügen

Suchen - Kopieren - Einfügen
Wolfgang
Hallo,
ich würde gerne erreichen, dass der in einer Suchmaske genannte Begriff in Spalte H des Tabellenblattes "Maßnahmen" gesucht wird und die jeweilige Zeile in der sich der Begriff befindet von A:H in das Tabellenblatt "Einstellungen" ab A15 hineinkopiert wird. In A14:H14 sollte immer jeweils die Überschrift aus "Maßnahmen" A1:H1 hineinkopiert wird. Der gesuchte Begriff kann häufiger vorkommen, so dass alle betroffenen Zeilen sich zum Schluß der Suche in Tabelle Einstellungen befinden sollten. Wäre das realisierbar bzw. wie müßte ich den folgenden Code anpassen? Danke schon jetzt für die Rückmeldungen.
Herzliche Grüße
Wolfgang

Sub SuchenKopieren()
Static Suchbegriff As String
Dim Zelle As Variant, ErsteAdresse As String
Dim LetzteZelle As Integer, intCount As Integer
Application.ScreenUpdating = False
Worksheets("Einstellungen").Range("A14:H1000").Cells.Clear 'Alte Tabelleninhalte lö _
schen
Suchbegriff = InputBox(Prompt:="Bitte Suchbegriff eingeben:", _
Default:=Suchbegriff)
If Suchbegriff = "" Then MsgBox "Bitte Suchbegriff eingeben", vbCritical
Exit Sub
With Worksheets("Maßnahmen")
'Überschriftenzeile kopieren ...
.Rows(1).Copy Destination:=Worksheets("Maßnahmen").Range("a1")
With .UsedRange
Set Zelle = .Find(What:=Suchbegriff, After:=Range("A1"), _
LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlNext, MatchCase:=True)
If Not Zelle Is Nothing Then
ErsteAdresse = Zelle.Address
LetzteZelle = 2
Do
.Rows(Zelle.Row).Copy _
Destination:=Worksheets("Einstellungen").Range("a14:H") _
.Cells(LetzteZelle, 1)
Set Zelle = .FindNext(Zelle)
LetzteZelle = LetzteZelle + 1
Loop While Not Zelle Is Nothing And _
Zelle.Address  ErsteAdresse
End If
Worksheets("Maßnahmen").Select
Range("a1").Select
End With
End With
Application.ScreenUpdating = True
End Sub

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Benutzer
Anzeige
AW: Suchen - Kopieren - Einfügen
05.10.2011 23:56:42
fcs
Hallo Wolfgang,
hier dein Code entsprechend angepasst und in eine Richtung getrimmt (wksQuelle, wksZiel), wie ich den Code strukturieren würde.
Gruß
Franz

Sub SuchenKopieren()
Static Suchbegriff As String
Dim Zelle As Variant, ErsteAdresse As String
Dim LetzteZeile As Integer
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Set wksQuelle = Worksheets("Maßnahmen")
Set wksZiel = Worksheets("Einstellung")
Application.ScreenUpdating = False
wksZiel.Range("A14:H1000").Cells.Clear 'Alte Tabelleninhalte löschen
Suchbegriff = InputBox(Prompt:="Bitte Suchbegriff eingeben:", _
Default:=Suchbegriff)
If Suchbegriff = "" Then
MsgBox "Bitte Suchbegriff eingeben", vbCritical
Exit Sub
End If
With wksQuelle
'Überschriftenzeile kopieren ...
.Range("A1:H1").Copy Destination:=wksZiel.Range("A14")
'Suche in Spalte H
Set Zelle = .Columns(8).Find(What:=Suchbegriff, After:=.Range("H1"), _
LookIn:=xlValues, lookat:=xlWhole, _
SearchOrder:=xlNext, MatchCase:=True)
If Not Zelle Is Nothing Then
ErsteAdresse = Zelle.Address
LetzteZeile = 15
Do
'gefundenen Zeile Spalten A bis H kopieren in nächste Zeile im Zielblatt
.Range(.Cells(Zelle.Row, 1), .Cells(Zelle.Row, 8)).Copy _
Destination:=wksZiel.Cells(LetzteZeile, 1)
'Suche wiederholen
Set Zelle = .Columns(8).FindNext(Zelle)
LetzteZeile = LetzteZeile + 1
Loop While Not Zelle Is Nothing And Zelle.Address  ErsteAdresse
End If
End With
wksZiel.Select
Range("A1").Select
Application.ScreenUpdating = True
End Sub

Anzeige
Danke Franz!! - läuft super
06.10.2011 06:01:35
Wolfgang
Hallo Franz,
herzlichen Dank für Deine schnelle Rückmeldung und den Code. Er läuft einwandfrei und super. Ich habe ihn ausprobiert und getestet. Mir fiel auch dabei ein, dass der Suchbegriff evtl. mit einem Komma, Semikolon o.ä. endet. Also, Jokerzeichen *ausprobiert, auch das klappt super.
Nochmals vielen vielen Dank dafür!!
Gruß - Wolfgang

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige