Kopieren von Wörtern mit bestimmten Buchstabenfolgen

Question

Hallo zusammen,

ich habe eine Excel-Tabelle mit Daten. Nun möchte ich aus Tabelle 1 sämtliche Wörter mit bestimmten Buchstabenfolgen kopieren.

Bsp.: Das Haus der Maus.

Ich suche nach "aus", nun sollen mir sämtliche Wörter in Tabelle 2 kopiert werden, die "aus" enthalten, also stünde in Tabelle 2 dann: Haus Maus. Im optimalen Fall stünden die zwei Ergebnisse dann in Tabelle 2 in zwei verschiedenen Spalten, aber alles in einer Spalte ginge notfalls auch.

Hat mir jemand eine Idee, wie ich das bewerkstelligen könnte? Über ein Makro?

Vielen Dank schon Mal!
Suki

Answer 1

P. S. Ich habe hier eine Makro-Vorlage, die eine Suche nach einzelnen Buchstaben erlaubt, ich müsste aber nach Buchstabenfolgen suchen können:


Option Explicit

Sub suchen_kopieren()

Application.ScreenUpdating = False
Dim Begriff As String, gefunden As Variant, firstAddress As Variant, _
Zeile As Long

Dim strSuchwort() As String
Dim iSuchwort As Integer
Dim iWortlänge As Integer

Begriff = InputBox("suche nach:", "Suchbegriff")
If Begriff = "" Then Exit Sub
With Sheets("Tabelle1").Cells
Set gefunden = .Find(Begriff, LookIn:=xlValues)
If Not gefunden Is Nothing Then
firstAddress = gefunden.Address
Do
'Text aus der gefundenen Zelle in einzelne Wörter aufsplitten
strSuchwort = Split(Range(gefunden.Address), " ")
'Alle Wörter der gefundenen Zelle durchsuchen
For iSuchwort = 0 To UBound(strSuchwort)
'Abgefragtes Wort Buchstabenweise durchsuchen
For iWortlänge = 1 To Len(strSuchwort(iSuchwort))
'Wenn abgefragter Buchstabe mit dem Suchbegriff übereinstimmt, Wort kopieren
If Mid(strSuchwort(iSuchwort), iWortlänge, 1) = Begriff Then
Sheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) = _
strSuchwort(iSuchwort)
End If
Next
Next
Set gefunden = .FindNext(gefunden)
Loop While Not gefunden Is Nothing And gefunden.Address <> firstAddress
End If
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Answer 2

Hallo Suki,

schau dir dazu mal die InStr - Funktion in VBA an: Lies mich!

Gruß

M.O.

Answer 3

Hallo M.O.

vielen Dank, habe es mir angeschaut! Leider steige ich da nicht so recht durch. Könntest du mir damit weiterhelfen? Und kennst du eine allgemeine Einführung in Makros?

Vielen Dank und liebe Grüße
Christina

Answer 4

hi Suki ^^

probier mal :-)

gruss Nighty

Eingabe eines Suchbegriffes
1 Tabelle Spalte A erfolgt die Suche
2 Tabelle Spalte A- ... erfolgt die Ausgabe

Sub Suchen()
Dim Daten As Variant, Zelle As Variant
Dim Eingabe As String
Dim WksZ As Long, WksSp As Long
Worksheets(1).Activate
Daten = Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
WksZ = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
Eingabe = InputBox("Suchbegriff eingeben")
For Each Zelle In Daten
If InStr(Zelle, Eingabe) > 0 Then
WksSp = WksSp + 1
Worksheets(2).Cells(WksZ, WksSp) = Zelle
End If
Next Zelle
End Sub

Answer 5

hi all ^^

mit mehrfachtreffern von wörtern

gruss nhty

Sub Suchen()
Dim Daten As Variant, Daten1 As Variant, Zelle As Variant
Dim Eingabe As String
Dim WksZ As Long, WksSp As Long
Dim AIndex As Integer
Worksheets(1).Activate
Daten = Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
WksZ = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
Eingabe = InputBox("Suchbegriff eingeben")
For Each Zelle In Daten
Daten1 = Split(Zelle, " ")
For AIndex = 0 To UBound(Daten1)
If InStr(Daten1(AIndex), Eingabe) > 0 Then
WksSp = WksSp + 1
Worksheets(2).Cells(WksZ, WksSp) = Daten1(AIndex)
End If
Next AIndex
Next Zelle
End Sub

Answer 6

Hallo Nighty,

vielen lieben Dank! Ich habe es gerade getestet, leider kommt bei mir die Fehlermeldung "Laufzeitfehler ‚1004‘: Anwendungs- oder objektdefinierter Fehler", woran kann das liegen? Die Zeile "Worksheets(2).Cells(WksZ, WksSp) = Zelle" bzw. "Worksheets(2).Cells(WksZ, WksSp) = Daten1(AIndex)" ist dann gelb markiert. Außerdem wollte ich fragen, wie man das machen müsste, dass die Daten dann in der Spalte A ausgegeben werden, also A1, A2, A3 etc.? Es scheinen nämlich nicht alle Daten (ungefähr 29.000) angezeigt werden zu können. Ich nehme an, da müsste "Range("A2:A"..." geändert werden? Die Daten müssten im Anschluss daran sortiert und ausgezählt werden. Geht das auch automatisch?
Beispiel:
Als Ergebnis in Tabelle 2 erhalte ich:
Haus
Haus
Haus
Maus
Maus
Laus
Dass man dann jeweils zählt und erhält
Haus: 3
Maus: 2
Laus: 1

Vielen Dank für eure wertvolle Hilfe!
Suki

Answer 7

Hallo Suki,

da du den Code gepostet hattest, war ich davon ausgegangen, dass du VBA beherrscht. Daher hatte ich nur den Link gepostet. Aber Nighty hat dir ja zwei Beispiele gepostet. Ich habe das 2. Beispiel von Nighty etwas erweitert, so dass das Makro nun das tun sollte, was du willst.
In deiner Arbeitsmappe müssen mindestens zwei Tabellen enthalten sein. Die Tabelle an 1. Stelle muss die zu durchsuchenden Daten enthalten, in die 2. Tabelle werden dann die Suchergebnisse kopiert.

Sub Suchen()

Dim Daten As Variant
Dim Daten1 As Variant
Dim Zelle As Variant
Dim Eingabe As String
Dim WksZ As Long
Dim AIndex As Integer
Dim Anfang As Long
Dim Ende As Long

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'eventuell vorhandene Daten in 2. Tabelle löschen
Worksheets(2).Cells.ClearContents

'zu durchsuchende Daten stehen in 1. Tabelle in der Arbeitsmappe
Worksheets(1).Activate
'die Daten werden in Array eingelesen
Daten = Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
'die gefundenen Daten werden in die zweite Tabelle der Arbeitsmappe geschrieben
'hier wird die erste freie Zeile ermittelt
WksZ = Worksheets(2).Cells(Rows.Count, 1).End(xlUp).Row + 1
Anfang = WksZ + 1
'Abfrage des Suchbegriffs
Eingabe = InputBox("Suchbegriff eingeben")
'Suchroutine
For Each Zelle In Daten
Daten1 = Split(Zelle, " ") 'Zelleninhalt wird aufgteilt, Trenner ist Leerzeichen
For AIndex = 0 To UBound(Daten1) 'aufgesplitteten Zellinhalt durchsuchen
If InStr(Daten1(AIndex), Eingabe) > 0 Then 'falls die Zeichenfolge gefunden wird,
WksZ = WksZ + 1 'Zähler um 1 erhöhen
Worksheets(2).Cells(WksZ, 1) = Daten1(AIndex) 'und Wort in Spalte A des 2. Tabellenblatts schreiben
End If
Next AIndex
Next Zelle

'gefundene Daten in Spalte T kopieren
With Worksheets(2)
.Activate
.Range(.Cells(Anfang, 1), .Cells(WksZ, 1)).Copy Destination:=.Cells(Anfang, 20)
'und sortieren
With .Sort
.SortFields.Clear
.SortFields.Add Key:=Range("T" & Anfang), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.SetRange Range("T" & Anfang & ":T" & WksZ)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Duplikate entfernen
.Range(.Cells(Anfang, 20), .Cells(WksZ, 20)).RemoveDuplicates Columns:=1, Header:=xlNo
End With


With Worksheets(2)
'letzte Zeile in Spalte 20 des Worksheets(2) ermitteln
Ende = .Cells(Rows.Count, 20).End(xlUp).Row

'gleiche Wörter zählen - mit Zählenwenn
For AIndex = Anfang To Ende
.Cells(AIndex, 21) = Application.WorksheetFunction.CountIf(.Range(.Cells(Anfang, 1), .Cells(WksZ, 1)), .Cells(AIndex, 20))
Next AIndex
'Spalten A und B löschen
.Range(.Cells(Anfang, 1), Cells(WksZ, 2)).ClearContents
'Daten von Spalte T in Spalte A verschieben
.Range(.Cells(Anfang, 20), .Cells(Ende, 21)).Cut Destination:=.Cells(Anfang, 1)
End With

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Zum VBA-lernen kannst du mal im Internet suchen (z.B. gibt es diese Seite: KLICK MICH). Aber ich finde am besten lernt man, wenn man einfach mal anfängt mit einem einfachen Makro. Im Laufe der Zeit steigert man sich automatisch. Und bei Problemen kann immer im Netz nach einer Lösung suchen oder z.B. hier wieder nachfragen ;-).

Gruß

M.O.

Answer 8

Hallo Suki,

noch ein Nachtrag zum VBA-Lernen: KLICK MICH! ;-)

Gruß

M.O.

Answer 9

Hallo M.O.,

vielen lieben Dank für die Links, das werde ich mir ansehen! Habe gegoogelt und noch nicht so viel für Anfänger gefunden.

Was das Makro betrifft: auch vielen vielen Dank dafür! Und ja, leider beherrsche ich es nicht, ich hatte das Makro, das ich gepostet hatte, erhalten, nicht selbst geschrieben.

Dein Makro habe ich getestet, hierbei ergaben sich zwei Probleme:

1) Es erscheint eine Fehlermeldung: "Laufzeitfehler '13': Typen unverträglich". Wenn ich auf "Debuggen" gehe, wird folgende Zeile gelb markiert:
Daten1 = Split(Zelle, " ") 'Zelleninhalt wird aufgteilt, Trenner ist Leerzeichen

2) Trotz der Fehlermeldung werden Daten in die zweite Tabelle kopiert. Ich habe allerdings in der Ausgangstabelle über "Suchen-Ersetzen" ermittelt, dass es 26159 "Treffer" gibt, in der zweiten Tabelle sind aber nur 17769 entsprechende Datensätze vorhanden. Ich habe mal von Beginn an durchgesehen, da stimmt alles. Jetzt habe ich einfach ein paar wenige Datensätze in ein Dokument kopiert und nochmals getestet. Hier erscheint keine Fehlermeldung und im Gegensatz zum vollständigen Dokument funktioniert hier auch die Zählung der einzelnen "Treffer", wobei merkwürdigerweise bei einigen jeweils 1 "Treffer" nicht mitgezählt wurde. Woran kann das liegen? Und könnte darin die oben genannte Differenz (26159 vs. 17769) begründet sein?

Ich wäre sehr froh, wenn du mir hier weiterhelfen könntest!

Viele Grüße,
Suki

Answer 10

Hallo Suki,

zu der Fehlermeldung kann ich ohne deine Datei leider nicht viel sagen. Wenn die Fehlermeldung erscheint, dann klicke auf Debuggen und gehe dann mit dem Cursor auf Zelle in der markierten Zeile. Was wird dann angezeigt?

Den Unterschied könnte ich mir eigentlich nur dadurch erklären, dass hier bei der Suche die Groß- und Kleinschreibung beachtet wird, während bei Suchen und Ersetzen die Groß- und Kleinschreibung standardmäßig nicht beachtet wird. So findest du bei der Suche nach "aus" z.B. Haus und Maus, aber nicht Ausfahrt. Wenn die Groß- und Kleinschreibung bei der Suche ignoriert werden soll, dann müsste den Code entsprechend ändern.

Gruß

M.O.