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)
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
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
…
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.
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.
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
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.
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.
