Office: Wörter suchen

Hallo Zusammen,

ich bin neu hier im Forum und habe es auf der Suche nach einer Lösung meines Problems gefunden *Smilie

Ich möchte die Spalte L im Tabellenblatt 1 nach eine Reihe von Wörtern, die im Tabellenblatt 2 aufgelistet sind, durchsuchen. Sobald eines oder mehrere der Wörter gefunden wurden soll die jeweilige Zeile komplett ins Tabellenblatt 3 kopiert werden.

Bisher habe ich den folgenden Code (größtenteils aus verschiedenen Beiträgen zusammengeschustert), der allerdings diverse Fehler hat.

Kann mir jemand helfen den Code zu optimieren? Würde mich echt freuen!

Liebe Grüße


Option Explicit

Sub Start()
Dim Suche As String
Suche = InputBox("Was soll kopiert werden?")
If Len(Suche) Then
MsgBox ("Es wurden " & AuswahlKopieren(Suche, True) & " Zeilen kopiert!")
End If
End Sub


Function AuswahlKopieren(SuchStr As String, Optional Ganz As Boolean = False) As Integer
'Mit Ganz=True wird der ganze Zellinhalt verglichen
'mit Ganz=False wird auch kopiert, wenn der Suchtext nur in der zelle vorkommt...

Dim WSq As Worksheet
Dim WSz As Worksheet
Dim WSw As Worksheet
Dim SuchColRng As Range
Dim FRng As Range
Dim CRng As Range
Dim FirstAdr As String
Dim CArr As Variant
Dim rngdata As Range
Dim rngSearch As Range
Dim rngOutput As Range

'Anpassen------------------------------
Set WSq = Worksheets("1")
Set WSw = Worksheets("2")
Set WSz = Worksheets("3")
Set SuchColRng = WSq.Range("L6:L6112")

Set rngdata = Worksheets(1).Range("L6:L6112" & Worksheets(1).Cells(Rows.Count, "1").End(xlUp).Row)
Set rngSearch = Worksheets(2).Range("A" & Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row)
Set rngOutput = Worksheets(3).Range("a1")

rngdata.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rngSearch, CopyToRange:=rngOutput, Unique:=False

'Anpassen------------------------------

With SuchColRng
If Ganz Then
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlWhole)
Else
Set FRng = .Find(SuchStr, LookIn:=xlValues, LookAt:=xlPart)
End If
If Not FRng Is Nothing Then
FirstAdr = FRng.Address
Do
If CRng Is Nothing Then
Set CRng = WSq.Rows(FRng.Row)
Else
Set CRng = Union(WSq.Rows(FRng.Row), CRng)
End If
Set FRng = .FindNext(FRng)
Loop While Not FRng Is Nothing And FRng.Address FirstAdr
End If
End With
If Not CRng Is Nothing Then
CRng.Copy
WSz.Cells(WSz.Cells(WSz.Rows.Count, SuchColRng.Column).End(xlUp).Row + 1, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
AuswahlKopieren = CRng.Cells.Count / 256
Else
AuswahlKopieren = 0
End If
End Function

:)

 

Hi Juli25,
ich weiß zwar nicht wo Du den Code her hast, aber der ist ... naja.. *rolleyes.gif*
Schau Dir mal das beigfügte File an.
ich hab da schnell mal was einfaches zusammengestrickt
öffne mal den VBA editor und lass das mal schrittweise (F8-taste) durchlaufen.
Vielleicht kannst Du das für dein Problem(chen) nutzen

Gruß
DeBabba

 

Hey DeBabba,

super, dein Bsp. funktioniert genauso wie ich es mir vorgestellt habe *mrcool

Leider ist meine Tabelle viel komplexer:
- Spalten von A bis U, wovon aber nur Spalter L duchsucht werden solll (wenn allerdings was gefunden wird soll die komplette Zeile in T3 kopiert werden)
- und hat 6112 Zeilen

Leider hab ich noch nicht so ganz den Durchblick wie ich deinen Code jetzt an meine Tabelle anpasse. Könntest du da gerade nochmal einspringen?

Tausend Dank *grins

 

Hi juli 25
aber klar doch
Hier ein paar Änderungsansatzhinweise (wow was ein Wort, gibt beim Scrabble mindestens 100 Punkte *grins )
der Befehl CELLS gibt in der ersten Stelle die Zeile an und in der 2. Stelle die Spalte. Bsp.: Cells(1,1) = Zelle A1 oder cells (2,12) = Zelle L2
Bei Deinem Code heißt das
1.) zum reihen zählen, wählst du die Spalte aus, in der "immer" was drin steht
2.) Ändere die Zeile in der gesuc´ht wird (E = Cells(D, 1).Value) in E=cells(d,12)
das müsste es auch schon gewesen sein
TIPP
Mach die mal ne kleine tabelle und probier einfach mal rum, nutze die Hilfe (F1) die ist meistens gar nicht so schlecht*wink.gif* *wink.gif*
Gruß
DeBabba

 

Danke, obiges habe ich angepasst *Smilie allerdings scheit sich der Code in eine Endlosschleife zu ziehen. Findest du im folgenden Code noch einen Fehler?

Option Explicit
Sub Versiv()
Dim A, B, C, D, E
Dim Suchbegriff As String
'anzahl Datensätze in Tabelle T1 zählen
A = Range(Sheets("T1").Cells(6, 12), Sheets("T1").Cells(6, 12).End(xlDown)).Rows.Count
'anzahl Datensätze in Tabelle T3 zählen
B = Range(Sheets("T2").Cells(6, 12), Sheets("T2").Cells(6, 12).End(xlDown)).Rows.Count
'Schleife ** Suchen und kopieren aller zeilen aus T2
For C = 2 To B
Suchbegriff = Sheets("T2").Cells(C, 1).Value
For D = 2 To A
Cells(D, 1).Select 'kann man weglassen, man sieht aber wo man ist
E = Cells(D, 12).Value
If E = Suchbegriff Then
ActiveCell.EntireRow.Copy
Sheets("T3").Cells(100, 1).End(xlUp).Offset(1, 0).PasteSpecial
End If
Next D
Next C

End Sub

 

Hi
nach wievielen Einträgen suchst Du ?
Schau mal was in der variablen B drin steht
'anzahl Datensätze in Tabelle T3 zählen
********************************
B = Range(Sheets("T2").Cells(6, 12), Sheetys("T2").Cells(6, 12).End(xlDown)).Rows.Count
********************************
T2 ist die Tabelle mit den Suchbegriffen . Du suchst diese in Spalte L ?!?!
Wenn da nix steht ...... dann B = 65536 und das dauert laaaaaannnnge *frown.gif*

Prüf das dochmal nach

Gruß
Klaus

 

Also zum probieren habe ich meine T1 Tabelle (wo in Spalte L gesucht werden soll) sehr verkleinert, die hat jetzt nur noch 12 Zeilen. Auch in T2 habe ich zur Probe erstmal nur ein Suchwort eingefügt und daher dürfte es nicht lange dauern.

Hab das Minibsp. mal rangehängt...

 

ok ok ,
habs mir nochmal angeschaut und ein paar kleine Änderungen im Makro durchgeführt.
1.) anzahl der suchbegriffe in T" (Makro variable B)
2.) da das gesuchte wort in einem Text vorkommen kann, muss der Ganze Text durchgesucht werden (das ist der Befehl INSTR) Die Rückgabe hier ist die Stelle im text an der das gesuchte wort beginnt. Ist die Zahl (F) größer 0 ist das wort vorhanden und die zeile wird kopiert.
habe im der Neispieltabelle das Wort "Building" verwendet.
Bin jetzt in nem Meeting und erst morgen wieder online
Sollte das nicht so funktionieren, bitte um Geduld

Gruß
De Babba

 

Du bist der Held der Woche *mrcool es läuft perfekt!!!!!!!*biggrin.gif* *biggrin.gif* *biggrin.gif* *biggrin.gif*

Eine Frage habe ich allerdings noch: Einige Zellen enthalten mehrere der Wörter, nach denen ich suche. Da das Makro T1 für jedes Suchwort einzeln durchläuft, werden auch Zeilen doppelt kopiert. Das ist suboptimal.

Ich habe mir gedacht, dass man im Makro entweder die Funktion "CUT" anstatt "COPY" einfügt, sodass bspw. beim zweiten Suchwort nicht mehr die Zellen durchsucht werden, in denen schon beim ersten Suchwort ein Treffer erzielt worden ist. Oder man schreibt das Makro so um, dass am Ende nochmal T3 nach doppelten Zeilen durchsucht wird und diese dann gelöscht werden.

Was meinst du ist besser? Und bei einer großen Datenmenge schneller?

Liebe Grüße & danke im Voraus!!!
JuLi

 

Hi Juli,
also das mit dem ausschneiden ist schon gut,
ABER
du killst damit Deine Ursprungstabelle, denn die entsprechenden Sätze verschwinden aus T1
---------
Ich habe einfach alles kopiert und dann einfach die doppelten entfernt (ich hoffe du arbeitest mit Office 2010)
Hier das Script
Code:

Ach ja... ich habe hinter den INSTR Befehl noch ein "vbTextCompare" gesetzt. Dies bewirk das ignorieren von Groß und Kleinschreibung

Gruß
De Babba

 

wunderbar, das funktioniert super *mrcool *mrcool *mrcool *mrcool

Liebe Grüße, JuLi

 

Hallo JuLi,
schön zu hören, dass es Dir so gefällt.
Da kann man aber noch ne Menge mehr machen.
Bitte vorsicht, denn das Ganze ist "nur mit der heißen Nadel gestrickt"
Wenn Du hier statt kopieren nur markieren willst, dann benutze doch mal diesen Teil
Statt
ActiveCell.EntireRow.Copy
nimm
Activecell.entirerow.enterior.colorindex = 33

damit färbst du die gefundene Zeile ein (farbmöglichkeiten von 1 bis 56)

nochmals Grüße
DeBabba - Klaus