Weitere Suchfunktion in VBA Code integrieren

Computer: Software & Programmierung Visual Basic
#1

Hallo liebe Leute,
vielleicht könnt Ihr mir helfen!
Mein VBA Wissen beruht auf Versuch und Zufall. Ich habe einen VBA Code den ich gezielt zur Filterung einer Datenbank verwende.
Leider müssen die Suchbegriffe sehr allgemein gefasst werden um die benötigten Informationen zu erhalten.

Jetzt die Frage: „Kann man in den VBA Code eine zusätzliche Funktion programmieren welche das Suchergebnis weiter einschränkt?“

  • Nach ewigen Versuch und Irrtum bin ich ratlos! -

Im Anhang habe ich den verwendeten Code angehängt.

Der Code sucht in der Quelledatei nach dem Stichwort Medien und legt mir dann das Ergebnis im Reiter C1 ab.

Die benötigte Funktion wäre, dass er wie bisher in der Quelledatei das Stichwort Medien sucht und das Ergebnis mit einer UND Verknüpfung z.B. das Stichwort Haus weiter verfeinert wird. Das zusätzlich gefilterte Ergebnis kommt dann wieder in den Reiter C1.

Sub Ceins()
Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long

Set wks1 = Worksheets(„Quelle“)
Set wks2 = Worksheets(„C1“)
wks2.Cells.Clear
With wks1.UsedRange
Set c = .Find(„Medien“, LookIn:=xlValues)

If Not c Is Nothing Then
firstaddress = c.Address
Zei = 2
Do
Zei = Zei + 1
c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
Set c = .FindNext©
Loop While Not c Is Nothing And c.Address firstaddress
wks1.Rows(„2:1“).Copy Destination:=wks2.Rows(„1:1“)
End If
End With
End Sub

Vielen Dank für eure Bemühung
lg Neuling1111

#2

Hallo Neuling,

probiere es mal mit den folgenden Ergänzungen.

Gruß
Franz

Sub Ceins()
 Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
 Dim Zelle2 As Range, strKriterien2 As String
 Set wks1 = Worksheets("Quelle")
 Set wks2 = Worksheets("C1")
 strKriterien2 = "Haus"
 wks2.Cells.Clear
 With wks1.UsedRange
 Set c = .Find("Medien", LookIn:=xlValues)

 If Not c Is Nothing Then
 firstaddress = c.Address
 Zei = 2
 Do
 With wks1
 For Each Zelle2 In .Range(.Cells(c.Row, 1), .Cells(c.Row, .Columns.Count).End(xlToLeft))
 If InStr(1, LCase(Zelle2.Text), LCase(strKriterien2)) \> 0 Then
 Zei = Zei + 1
 c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
 Exit For
 End If
 Next
 End With
 Set c = .FindNext(c)
 Loop While Not c Is Nothing And c.Address firstaddress
 wks1.Rows("2:1").Copy Destination:=wks2.Rows("1:1")
 End If
 End With
End Sub
#3

Hallo
ich mache solche Abfragen in der Regel mit Select Case oder UBound und Split.
dim txt as string
dim a(0)
…
a= split(txt,„Haus“)
If Ubound(a(0)) 0 Then
'Datensatz gefunden
for l=0 to ubound
tabelle1.cells(i,3) = a(0)(l)
i += 1 'i+1
next l
end if
…

Grüsse Sebastian

#4

Hallo Neuling1111,

warum nach Do die Variable Zei gleich erhöhen?
sollte das nicht erst nach bearbeitung erfolgen?.
Da ich selbst in VBA noch nicht so fitt bin, kann ich leider nicht weiter helfen.

Gruß Hugo

#5

Ich gedenke auf deine Frage schon vorläufig mit, „ja das geht mit VBA“ antworten zu können

z.b mit

if instr(1, cells(1,1).value, „Medien“) then --> Gibt True aus, wenn in der Zelle 1,1 (A1) das Wort „Medien“ steht
…msgbox „Juhu wir haben was gefunden“
end if

dann mit einer zweiten verfeinern

if instr(1, cells(1,1).value, „Haus“) then
…mach irgendwas
end if

dann musst du dir halt noch überlegen, wie du alles durchsuchen willst.

z.b. mit
for each zelle in activeworksheet.cells
…if instr(1,zelle.value,„Medium“)
next zelle

alle zellen des worksheets

oder for each zelle in Range(„A1:H29“).cells
…mach was mit zelle in BEreich
next zelle

oder mit Zähler
for zeile=1 to 50
…for spalte = 1 to 30
…if instr(1,cells(zeile,spalte).value, „Suchtext“

…next spalte
next zeile

so ich hoffe das sind erst mal ein paar anregungen.
:wink:

LG OVM

#6

Hallo Franz vielen herzlichen Dank für deine Unterstützung!

Deine Lösung funktioniert.
Bei meinem gestrigen Versuch konnte ich es nach deiner Vorgabe gut umsetzen.

Besteht die Möglichkeit auf den Code aufzusetzen um etwas auszuschließen?
Da bei einer Abfrage die UND Verknüpfung nicht funktioniert.

Hier wäre eine Ausschluss eines bestimmten Wortes, ähnlich wie bei einer Filterfunktion - enthält nicht „Auto“ - die Lösung.

Vielen Dank für deine Bemühung
lg Neuling

#7

Hallo es gibt in VBA folgende Möglichkeiten:

if … then
elseif … then

endif

desweiteren besteht die Möglichkeit if … AND … then
usw

sollte ungefähr dem Problem entsprechen, einfach mal in der VBA Hilfe suchen

do loop würde ich vermeiden, weil es mit der Abbruchbedingung häufig zu Problemen kommt

Gruss

#8

Hallo Neuling,

probier es mal mit der folgenden Variante.

Hier können die Inhalte der beiden zusätzlichen Kriterien in 2 verschiedenen Zellen stehen.

Gruß
Franz

Sub Ceins()
 Dim c, firstaddress, wks1 As Worksheet, wks2 As Worksheet, Zei As Long
 Dim Zelle2 As Range, strKriterien(1 To 3) As String, bolCopy As Boolean
 Set wks1 = Worksheets("Quelle")
 Set wks2 = Worksheets("C1")
 strKriterien(1) = "Medien" 'Hauptkriterium
 strKriterien(2) = "Haus" 'weiteres Musskriterium
 strKriterien(3) = "Auto" 'Auschlusskriterium
 wks2.Cells.Clear
 With wks1.UsedRange
 Set c = .Find(strKriterien(1), LookIn:=xlValues)

 If Not c Is Nothing Then
 firstaddress = c.Address
 Zei = 2
 bolCopy = False
 Do
 With wks1
 For Each Zelle2 In .Range(.Cells(c.Row, 1), .Cells(c.Row, .Columns.Count).End(xlToLeft))
 'Negativ-Kriterium - Ausschlusskriterium
 If InStr(1, LCase(Zelle2.Text), LCase(strKriterien(3))) \> 0 Then
 bolCopy = False
 Exit For
 End If
 'weiteres Musskriterium
 If InStr(1, LCase(Zelle2.Text), LCase(strKriterien(2))) \> 0 Then bolCopy = True
 Next
 If bolCopy = True Then
 Zei = Zei + 1
 c.EntireRow.Copy Destination:=wks2.Cells(Zei, 1)
 End If
 End With
 Set c = .FindNext(c)
 Loop While Not c Is Nothing And c.Address firstaddress
 wks1.Rows("2:1").Copy Destination:=wks2.Rows("1:1")
 End If
 End With
End Sub
#9

Hallo Franz,
ich bin aus dem Häuschen!

Vielen Dank für deine Unterstützung, so hätte ich das nie hinbekommen.
Der Code ist jetzt genau so wie ich ihn benötige um die Ideal Abfrage zu erhalten.

Die Aufschlüsselung, was welche Funktion erfüllt, hilft mir ungemein.
So kann ich je nach Bedarf die Abfrage aufbohren.

Deine Mithilfe hat mir wirklich sehr sehr viel geholfen.

Ich wünsche dir ein wunderschönes Wochenende und ein erfolgreiches und gesundes 2013.

vlg Neuling

#10

Hallo Neuling,

ich würde versuchen, per VBA den Autofilter anzustoßen, denn damit kannst Du mehrere Spalten filtern und anschließend die Zeilen kopieren.
Zeichne Dir einfach mal ein VBA-Code auf, in dem
Du den Autofilter setzt.
Geht eigentlich ganz einfach.

Gruß,
Ptonka