PDA

Vollständige Version anzeigen : Tool um Datensatz zu durchsuchen und Zeilen kopieren


testuserxxl
01.07.2015, 08:19
Hallo liebe MS Office Forum- Community,

ich habe die Aufgabe ein kleines Suchtool in vba zu programmieren und bin hier fast am verzweifeln. Meine "Frankensteincodes", zusammengebastelt aus diversen Forenbeiträgen, funktionieren nur bedingt und für tiefergehende Anpassungen fehlt mir das know- how.
Ich hoffe ihr Jungs (und Mädels) könnt einem kleinen Dummchen weiterhelfen :)


Hier die Anforderungen:
Anforderung ist ein Suchtool, bei dem man einen Datensatz, sowie relevante Suchbegriffe eingeben kann und der Datensatz dann auf die Suchbegriffe gescannt wird. Zeilen mit einem Treffer sollen dann in ein extra Tabellenblatt (noch schöner wäre nach natürlich in eine ganz neue Datei ;-) ) kopiert werden, mit einer Anzeige, welche Suchbegriffe verwendet wurden.
Der vba-code sollte dabei so ausgelegt werden, dass der Datensatz jedes mal eine andere Größe (Zeilen und Spalten) haben kann.

Aus Performancegründen sollte die Suche ab dem ersten Treffer in einer Zeile abgebrochen werden, da eine Zeile sowieso ab min. einem Treffer kopiert werden soll.

Grobkonzept:
Tabelle mit 3 Tabellenblättern:
1. Blatt („Datensatz“)
2. Blatt („Suchbegriffe“)
3. Blatt („Ergebnis“) // oder gleich in eine neue (bereits geöffnete) Datei

Im ersten Blatt soll man eine Tabelle einfügen können mit X Zeilen und Y Spalten (Tabelle sollte jedes mal eine andere Größe haben können  dynamisch)

Im zweiten Blatt soll man in Spalte A bis zu 20 Suchbegriffe eingeben können (ein Suchbegriff je Zeile)

In das dritte Blatt sollen die Zeilen (aus Blatt 1) kopiert werden, die min. einen Suchbegriff aufweisen. Doppellte Zeilen sollen vermeiden werden.
Weiterhin wäre eine Anzeige schön (vllt in den ersten Zeilen), welche Suchbegriffe verwendet wurden.

Ich hoffe sehr, dass ihr mir helfen könnt! :)

Liebe Grüße
Madeleine

chris-kaiser
01.07.2015, 10:23
Hallo Madeleine,

funktionieren nur bedingt und für tiefergehende Anpassungen fehlt mir das know- how.


Ich kann in deinem Post nichts erkennen was angepasst werden sollte!?

Soll das neu erstellt werden?
Wenn ja, dann könntest Du auch hier nachfragen http://www.ms-office-forum.de/forum/forumdisplay.php?f=48

Wenn nein, dann wäre es von Vorteil wenn du eine Beispieldatei einstellen würdest (die dem Aufbau des Originals entspricht) und darin beschreibst was noch angepasst werden sollte.

testuserxxl
01.07.2015, 10:39
Hallo Chris,
danke für deine Antwort!

Hier der vorläufige Code (zum größten Teil von dem user "DeBabba" - Copyrights habe ich keine entdeckt :P):


Option Explicit
Sub Selektion()

Dim A, B, C, D, E, F, X
Dim Suchbegriff As String

'Datensätze in Tabelle Datensatz zählen:
A = Range(Sheets("Datensatz").Cells(6, 12), Sheets("Datensatz").Cells(6, 12).End(xlDown)).Rows.Count

'Suchbegriffe in Tabelle Suchbegriffe zählen:
B = Range(Sheets("Suchbegriffe").Cells(1, 1), Sheets("Suchbegriffe").Cells(1, 1).End(xlDown)).Rows.Count

'Schleife/ Suchen und kopieren aller Zeilen aus Suchbegriffe
For C = 2 To B
Suchbegriff = Sheets("Suchbegriffe").Cells(C, 1).Value
For D = 2 To A + 6
Cells(D, 1).Select 'optional
For X = 1 To A + 6
E = Cells(D, X).Value
F = InStr(1, E, Suchbegriff)

If F > 0 Then
ActiveCell.EntireRow.Copy
Sheets("Ergebnis").Cells(100, 1).End(xlUp).Offset(1, 0).PasteSpecial
End If
Next X
F = 0
Next D
Next C

End Sub

testuserxxl
01.07.2015, 12:14
So ich habe hier jetzt einen Code, der die groben Anforderungen abdeckt.
Allerdings fehlt mir noch:
- die Möglichkeit mehrere Suchbegriffe einzugeben
- eine automatisches Kopieren der ersten Zeile in die Ergebnisliste beim starten der Suchfunktion
- die Anzeige in der Ergebnisliste, welche Suchbegriffe verwendet wurden.

Damit komme ich einfach nicht weiter :(

Kann mir da jemand helfen?

Liebe Grüße
Madeleine

Sub suchen_kopieren()
Application.ScreenUpdating = False
Dim Begriff As String, gefunden As Variant, firstAddress As Variant
Begriff = InputBox("Suche nach:", "Suchbegriff")
If Begriff = "" Then Exit Sub
With Worksheets(1).Cells
Set gefunden = .Find(Begriff, LookIn:=xlValues)
If Not gefunden Is Nothing Then
firstAddress = gefunden.Address
Do
gefunden.EntireRow.Copy
Sheets(3).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial
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

testuserxxl
01.07.2015, 12:35
Okey, habe jetzt schon mal das Problem mit der ersten Zeile gelöst, durch das
einfügen folgenden Befehls, ganz am Anfang des Codes:

Sheets(1).Rows(1).Copy Destination:=Sheets(3).Rows(1)