Anzeige
Archiv - Navigation
1780to1784
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

wort finden und kopieren

wort finden und kopieren
07.09.2020 12:54:23
Dominik
Hallo
Ich komme bei einem Makro nicht weiter, villeicht hat jemand von euch eine Idee. Ich wollte es eigentlich selber schaffen habe in diesem Forum einen Code gefunden der fast das tut was ich erreichen möchte, nur leider läuft der nach meinen anpassungen garnicht und ich würde gerne noch ein paar funktionen dazu haben.
Sub Buchen()
Dim loLetzte As Long
If Target.Column = 2 And Target.Row + 11 Then
If Target.Value = "Tabelle2" Then
loLetzte = Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row + 1
Target.EntireRow.Copy Sheets("Tabelle2").Cells(loLetzte, 1)
Application.CutCopyMode = False
End If
End If
End Sub
Das Ziel was ereicht werden soll ist in Tabelle 1 soll nach einem dem Wort Hallo gesucht werden (das Wort wird in mehreren Spalten vorkommen), wenn das Wort gefunden wurde soll die ganze Zeile A - F kopiert werden und in Tabelle 2 ab Spalte 10 abgelegt werden.
Diese Prozedur soll noch ein zweites mal gestartet werden, nur soll nach dem Wort tschüss in Tabelle1 gesucht werden und dann in Tabelle 3 ab Spalte 10 abgelegt werden.
Über eine Lösung würde ich mich sehr freuen

10
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: wort finden und kopieren
07.09.2020 14:21:22
Werner
Hallo,
dein Makro ist gelinde gesagt Schrott. Das ist ja wohl offensichtlich aus einem Event-Makro übernommen, dort gibt es nämlich Target.
Teste mal:
Option Explicit
Sub Suchen()
Dim strSuche As String, strSuche1 As String, raFund As Range
Dim raTreffer As Range, strFirst As String
strSuche = "Hallo"
strSuche1 = "tschüss"
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
Set raTreffer = Nothing
Set raFund = .Cells.Find(what:=strSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
Set raFund = .Cells.FindNext(raFund)
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Tabelle2")
.Cells(.Rows.Count, "J").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
Set raTreffer = Nothing
Set raFund = .Cells.Find(what:=strSuche1, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
Set raFund = .Cells.FindNext(raFund)
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Tabelle3")
.Cells(.Rows.Count, "J").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
End With
Application.CutCopyMode = False
Set raFund = Nothing: Set raTreffer = Nothing
End Sub
Gruß Werner
Anzeige
Feedback
12.09.2020 11:26:07
Dominik
Hallo Werner
Erstmal vielen Dank für deine Mühe
Sorry stehe hier vorn einem Problem und wollte es versuchen selber zu Lösen daher habe ich noch kein Feedback gegeben. Ich habe deinen Code an meiner Mappe angepasst nur leider hat es nicht ganz geklappt.
Von Tablle 1 in 2 kopieren klappt, von Tablle 1 in 3 kopiert er mir immer Zeile 7 mit die eigentlich als Überschrift gedacht ist. Ich habe die letzten Tage versucht den Fehler ausfindig zu machen nur leider muss ich mir eingestehen das ich es ohne deine Hilfe wohl nicht schaffen werde.Magst du dir das villeicht nochmal anschauen?
Ich Lade dir die ganze Arbeitsmape mit hoch dann ist es für dich bestimmt übersichtlicher
https://www.herber.de/bbs/user/140204.xlsm
Schönen Danke
Dominik
Sub Buchen()
Dim strSuche As String, strSuche1 As String, raFund As Range
Dim raTreffer As Range, strFirst As String
strSuche = "Müll"
strSuche1 = "Schrott"
Application.ScreenUpdating = False
With Worksheets("Main")
Set raTreffer = Nothing
Set raFund = .Cells.Find(what:=strSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
Set raFund = .Cells.FindNext(raFund)
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Mull")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
Set raTreffer = Nothing
Set raFund = .Cells.Find(what:=strSuche1, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
Set raFund = .Cells.FindNext(raFund)
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Schrott")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
End With
Application.CutCopyMode = False
Set raFund = Nothing: Set raTreffer = Nothing
End Sub

Anzeige
AW: Feedback
13.09.2020 12:21:15
fcs
Hallo Dominik,
Problem-Ursache: in Zelle K7 steht das Wort "Schrott". Deshalb wird die Zeile 7 (=Titelzeile) kopiert.
Du musst die Suche auf die Spalte B beschränken.
Ich hab dir auch noch eine etwas kompaktere Variante erstellt. Hier werden die Suchbegriffe in einer Schleife abgearbeitet. Insbesondere wenn du noch mehr Suchbegriffe hast, dann wird das Makro nicht ewig lang.
LG
Franz
Sub Buchen()
Dim strSuche As String, strSuche1 As String, raFund As Range
Dim raTreffer As Range, strFirst As String
strSuche = "Müll"
strSuche1 = "Schrott"
Application.ScreenUpdating = False
With Worksheets("Main")
Set raTreffer = Nothing
Set raFund = .Range("B:B").Find(what:=strSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Set raFund = .Range("B:B").FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Mull")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
Set raTreffer = Nothing
Set raFund = .Range("B:B").Find(what:=strSuche1, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Set raFund = .Range("B:B").FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With Worksheets("Schrott")
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
End With
Application.CutCopyMode = False
Set raFund = Nothing: Set raTreffer = Nothing
End Sub

Sub Buchen_Variante()
Dim strSuche As String, intSuche As Integer, raFund As Range
Dim wksZiel As Worksheet
Dim raTreffer As Range, strFirst As String
Application.ScreenUpdating = False
For intSuche = 1 To 2
Select Case intSuche
Case 1
strSuche = "Müll"
Set wksZiel = ThisWorkbook.Worksheets("Mull")
Case 2
strSuche = "Schrott"
Set wksZiel = ThisWorkbook.Worksheets("Schrott")
End Select
With Worksheets("Main")
Set raTreffer = Nothing
Set raFund = .Range("B:B").Find(what:=strSuche, LookIn:=xlValues, lookat:=xlWhole)
If Not raFund Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
strFirst = raFund.Address
Do
If raTreffer Is Nothing Then
Set raTreffer = .Range("A" & raFund.Row & ":F" & raFund.Row)
Else
Set raTreffer = Union(raTreffer, .Range("A" & raFund.Row & ":F" & raFund.Row))
End If
Set raFund = .Range("B:B").FindNext(raFund)
Loop While Not raFund Is Nothing And raFund.Address  strFirst
If Not raTreffer Is Nothing Then
raTreffer.Copy
With wksZiel
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
End If
End If
Set raTreffer = Nothing
End With
Next intSuche
Application.CutCopyMode = False
Set raFund = Nothing: Set raTreffer = Nothing
End Sub

Anzeige
AW: Feedback
13.09.2020 22:13:13
Dominik
Hallo
Oh ok jetzt verstehe ich das Problem.
Es läuft jetzt, vielen Danke für deine Hilfe,
Nochmals dank an
Werner
fcs
Peter Kloßek
ihr habt mir sehr geholfen, Ich finde es ist eine sehr nette Geeste von euch anderen bei einem Problem zu helfen, ich möchte mich auch noch bei dem Forum Betreiber bedanken der diese Plattform zur verfügung stellt
Dankeschön Gruß Dominik
AW: Feedback
13.09.2020 13:09:16
Werner
Hallo,
warum schreibst du im Eingangsbeitrag das hier
das Wort wird in mehreren Spalten vorkommen
wenn deine Suchbegriffe nur in Spalte B vorkommen?
Option Explicit
Sub Buchen()
Dim strSuche As String, strSuche1 As String
strSuche = "Müll"
strSuche1 = "Schrott"
Application.ScreenUpdating = False
With Worksheets("Main")
If WorksheetFunction.CountIf(.Columns("B"), strSuche) > 0 Then
.Range("A8").AutoFilter field:=2, Criteria1:=strSuche
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
End With
With Worksheets(strSuche)
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Else
MsgBox "Fehler: Der Suchbegriff " & strSuche & " ist nicht vorhanden."
End If
If WorksheetFunction.CountIf(.Columns("B"), strSuche1) > 0 Then
.Range("A8").AutoFilter field:=2, Criteria1:=strSuche1
With .AutoFilter.Range
.Offset(1).Resize(.Rows.Count - 1).Copy
End With
With Worksheets(strSuche1)
.Cells(.Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
End With
Else
MsgBox "Fehler: Der Suchbegriff " & strSuche1 & " ist nicht vorhanden."
End If
If .AutoFilterMode Then .AutoFilterMode = False
End With
Application.CutCopyMode = False
End Sub
Gruß Werner
Anzeige
AW: Feedback
13.09.2020 21:58:12
Dominik
Hallo Werner
Tut mir sehr leid ich hatte Spalten mit Zeilen verwechselt, war ein Denkfehler.
Es läuft jetzt so wie es soll.
Ich bedanke mich nochmal vielmals bei dir für deine tolle Hilfe
Gruß Dominik
Gerne u. Danke für die Rückmeldung. o.w.T.
13.09.2020 23:12:15
Werner
schon mal was von Feedback gehört? o.w.T.
11.09.2020 23:10:47
Feedback
AW: Tabelle auf Arbeitsblätter verteilen
13.09.2020 12:45:29
Peter
Hallo Dominik,
Dein Problem läßt sich am besten mit dem Spezialfilter lösen. Ich habe Deine Datei ein wenig umgebaut, u.a. habe ich das Blatt "Spezialfilter" hinzugefügt und das Blatt "Mull" in "Müll" geändert. Außerdem habe ich einen weiteren Begriff (2. Wahl) hinzugefügt. Das dafür noch fehlende Blatt wird automatisch eingerichtet. Das Blatt "Spezialfilter" ist verborgen und wird bei Bedarf in den Makros (Modul 4) geöffnet und geschlossen.
Hier die umgebaute Datei:
https://www.herber.de/bbs/user/140209.xlsm
Bitte mal ausprobieren, Rückmeldung wäre schön.
Mit freundlichem Gruß
Peter Kloßek
Anzeige
AW: Tabelle auf Arbeitsblätter verteilen
13.09.2020 22:00:16
Dominik
Läuft Perfekt.
Vielen Dank das du dir Zeit genommen hast um mir bei meinem Problem zu helfen.
Gruß Dominik

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige