Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
936to940
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
936to940
936to940
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

erweiterte Suchfunktion?

erweiterte Suchfunktion?
02.01.2008 21:38:08
Gerhard
Hallo miteinand...
jetzt wirds a bissle komplizierter :-)
Ich verwende folgenden Code:

Private Sub cmdWeiter_Click()
bAction = True
Dim wsTmp As Worksheet, lngZ As Long
Set wsTmp = Worksheets.Add 'später löschen, wenn nicht mehr gebraucht
ActiveSheet.Name = "Rechnungen"
With Worksheets("BPF")
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
.Cells(1, 1).AutoFilter Field:=43, Criteria1:=txtLFSNr
.Range(.Rows(1), .Rows(lngZ)).Copy wsTmp.Cells(1, 1)
End Sub


Hier wird ein Autofilter gesetzt, kopiert und ein neues Tabellenblatt angelegt, so das ich eine Listbox füllen kann die mehr als 10 Spalten hat.
Zu meinem Problem:
Ich habe in einer weiteren Spalte nochmals Lieferscheinnummern stehen (Zur Erläuterung, eine Bestellung kann auch aus 2 Lieferungen bestehen, deshalb 2 Lieferscheinnummern)
Gibt es die Möglichkeit oben genannten Code so umzubauen, das er zuerst die Spalte 45 den Autofiltermit der gewünschten LFSNummer setzt, das Blatt anlegt, schaut ob in Zeile 2 ein Eintrag ist, wenn nicht, dieses Blatt wieder löscht, in Spalte 55 den Autofilter mit der gewünschten LFSNr, setzt und dann das Blatt anlegt. Wenn auch in diesem Blatt in Zeile 2 keine Eintragung ist, ne MSG Box ausgibt, mit dem Hinweis das kein LFS mit dieser Nummer vermekt ist.
Mir fehlt zu soetwas noch das Wissen, und hoffe auf eure Hilfe, weil sollte dies ned Möglich sein, war die ganze Wochenlange Mühe umsonst, diese Mappe zu basteln.
Thx n greetz
Gerhard Just

11
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: erweiterte Suchfunktion?
02.01.2008 22:06:00
Uduuh
Hallo,
warum willst du die Daten (ist doch wohl nur 1 Datensatz) in eine Listbox schreiben?
Oder verstehe ich was falsch?

Private Sub cmdWeiter_Click()
bAction = True
Dim wsTmp As Worksheet, lngZ As Long, vntTmp, lngRow As Long, blnFound As Boolean
Set wsTmp = Worksheets.Add 'später löschen, wenn nicht mehr gebraucht
wsTmp.Name = "Rechnungen"
With Worksheets("BPF")
vntTmp = .Range("a1").CurrentRegion
For lngRow = 2 To UBound(vntTmp)
If vntTmp(lngRow, 43) = txtLFSNR Or vntTmp(lngRow, 55) = txtLFSNR Then
.Rows(lngRow).Copy wsTmp.Cells(1, 1)
blnFound = True
Exit For
Next lngRow
End With
If Not blnFound Then MsgBox "LS nicht gefunden"
End Sub


Gruß aus’m Pott
Udo

Anzeige
AW: erweiterte Suchfunktion?
02.01.2008 22:17:04
Gerhard
Nabend Udo
Erst mal danke für deine Hilfe!!!!!!!!!!!!
Neee is ned nur ein Datensatz, sondern mehrere (weil mehrere bestellte Artikel auf einem LFS ja zusammengefasst sein konnen) die die gleiche LFS Nummer haben
Greetz Gerhard

AW: erweiterte Suchfunktion?
02.01.2008 22:29:00
Uduuh
Hallo,
OK, dann so:

Private Sub cmdWeiter_Click()
bAction = True
Application.ScreenUpdating = False
Dim wsTmp As Worksheet, lngZ As Long, vntTmp, lngRow As Long, blnFound As Boolean
Set wsTmp = Worksheets.Add 'später löschen, wenn nicht mehr gebraucht
wsTmp.Name = "Rechnungen"
With Worksheets("BPF")
vntTmp = .Range("a1").CurrentRegion
For lngRow = 2 To UBound(vntTmp)
If vntTmp(lngRow, 43) = txtLFSNR Or vntTmp(lngRow, 55) = txtLFSNR Then
.Rows(lngRow).Copy wsTmp.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
blnFound = True
Exit For
Next lngRow
End With
If Not blnFound Then MsgBox "LS nicht gefunden"
Application.ScreenUpdating = True
End Sub


Normalerweise würde ich erst alle gefundenen Datensätze in ein Array schreiben und dieses dann in die Hilfstabelle, dazu hab ich jetzt aber keine Lust.
Gruß aus’m Pott
Udo

Anzeige
AW: erweiterte Suchfunktion?
02.01.2008 22:33:23
Uduuh
Hallo,
hinter Exit For fehlt End If
Gruß aus’m Pott
Udo

AW: erweiterte Suchfunktion?
02.01.2008 23:23:00
Gerhard
Hallo....
Sorry...
Aber jetzt bekomme ich den Fehler
Laufzeitfehler 13
Typen unverträglich
an dieser Stelle:
For lngRow = 2 To UBound(vntTmp)
LG Gerhard

AW: erweiterte Suchfunktion?
02.01.2008 23:31:00
Gerhard
ich nochmal...
kann es sein das ich etwas nicht genau genug erläutert habe? Sorry wenns so ist!!!
Und zwar soll in Tabellenblatt Rechnungen nachgeschaut werden ob in Zele 2 eine Eintragung vorhanden ist, nicht in Tabellenblatt BPF.
Also nur um nicht missverstanden zu werden:
In BPF Autofilter in Spalte 43 setzen.
Gefiltertes Blatt kopieren und in neu erstelles Blatt Rechnungen einfügen.
Überprüfen ob in Tabellenblatt Rechnungen Zelle A2 eine Eintragung ist, wenn ja Ende, wenn nein Tabellenblatt Rechnungen löschen, in Tabelle BPF Autofilter in Spalte 55 setzen, Tabellen Blatt Rechnungen erstellen und gefiltertes Tabellenblatt BPF kopieren und in Rechnungen einfügen. Wiederum überprüfen ob in Tabellenblatt Rechnungen A2 eine eintragung ist, wenn ja , Ende, wenn nein MSGbox.
Wie gesagt sorry wenn ich es anfangs ned ordentlich erklärt habe... *schäm*
LG Gerhard

Anzeige
AW: erweiterte Suchfunktion?
03.01.2008 00:00:00
Uduuh
Hallo,
ich glaube nicht, dass ich das falsch verstanden habe.
Zur Erklärung:
Die komplette Tabelle BPF wird in ein Datenfeld eingelesen, da dieses schneller zu durchsuchen ist als die Tabelle selbst.
Wird entweder in Spalte 43 oder 55 die LS-Nr gefunden, wird die komplette Zeile in Rechnungen kopiert.
Rechnungen ist doch wohl deine Quelle für die Listbox, oder?
Ansonsten lad mal die Mappe hoch, den Fehler kann ich sonst nicht reproduzieren.

Private Sub cmdWeiter_Click()
bAction = True
Application.ScreenUpdating = False
Dim wsTmp As Worksheet, lngZ As Long, vntTmp, lngRow As Long, blnFound As Boolean
Set wsTmp = Worksheets.Add 'später löschen, wenn nicht mehr gebraucht
wsTmp.Name = "Rechnungen"
With Worksheets("BPF")
vntTmp = .Range("a1").CurrentRegion
For lngRow = 2 To UBound(vntTmp)
If vntTmp(lngRow, 43) = txtLFSNR Or vntTmp(lngRow, 55) = txtLFSNR Then
.Rows(lngRow).Copy wsTmp.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
blnFound = True
Exit For
Next lngRow
End With
If Not blnFound Then
MsgBox "LS nicht gefunden"
wsTmp.Delete
End If
Application.ScreenUpdating = True
End Sub


Gruß aus’m Pott und gute Nacht
Udo

Anzeige
AW: erweiterte Suchfunktion?
03.01.2008 04:28:00
Gerhard
Hallo
hier mal die Mappe
http://www.topdog24-7.de/Bestellplattform.xls
Es geht um das UF UserForm7b_Rechnungsangaben. Hier benötige ich den Code.
habe die Mappe auf meinen Space laden müssen, da mittlweile über 300 kB gross
Thx für die Mühe
Greetz Gerhard

AW: erweiterte Suchfunktion?
03.01.2008 11:51:16
Rudi
Hallo,
das klappt bei mir:

Private Sub cmdWeiter_Click()
Dim wsTmp As Worksheet, lngZ As Long
Dim vntTmp, lngRow As Long
bAction = True
If txtDatum = "" Then MsgBox "Datum muss ausgefüllt werden!", vbCritical: Exit Sub
If cboUeberprueftVon = "" Then MsgBox "Überprüft von... muss ausgefüllt werden!", vbCritical: _
Exit Sub
If txtRGNr = "" Then MsgBox "Rechnungsnummer muss ausgefüllt werden!", vbCritical: Exit Sub
If txtLFSNr = "" Then MsgBox "Lieferscheinnummer muss ausgefüllt werden!", vbCritical: Exit  _
Sub
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("Rechnungen").Delete
Application.DisplayAlerts = True
On Error GoTo 0
With Sheets("HILFSTABELLE")
erste_freie_Zeile2 = .Range("S65536").End(xlUp).Offset(1, 0).Row
.Cells(erste_freie_Zeile2, 20) = CDate(txtDatum)
.Cells(erste_freie_Zeile2, 21) = txtRGNr
.Cells(erste_freie_Zeile2, 22) = cboUeberprueftVon
End With
With Worksheets("BPF")
.FilterMode = False
lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
vntTmp = .Range(.Cells(7, 1), .Cells(lngZ, 72))
End With
For lngRow = 1 To UBound(vntTmp)
If vntTmp(lngRow, 43) = txtLFSNr Or vntTmp(lngRow, 55) = txtLFSNr Then
If wsTmp Is Nothing Then
Set wsTmp = Worksheets.Add
wsTmp.Name = "Rechnungen"
Worksheets("BPF").Rows(6).Copy wsTmp.Cells(1, 1)
End If
Worksheets("BPF").Rows(lngRow + 6).Copy _
wsTmp.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
End If
Next lngRow
Application.ScreenUpdating = True
If Not wsTmp Is Nothing Then
Call SortierenRechnungen
lngZ = wsTmp.Cells(Rows.Count, 1).End(xlUp).Row ' Anz. Zeilen in wsTmp
Worksheets("ÜBERSICHT").Select
Me.Hide
UserForm7_Rechnung_Eintragen.Show
Else
MsgBox "Nicht gefunden"
Me.Hide
Unload Me
'Call LFSNr_Überprüfen
End If
End Sub


Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe

Anzeige
AW: erweiterte Suchfunktion? DANKE!!!!
03.01.2008 14:43:00
Gerhard
Dankööööööööö Rudi!!!!
Es klappt auch bei mir ;-)
greetz and many thx
Gerhard

AW: erweiterte Suchfunktion?
02.01.2008 22:29:00
Gerhard
Nochmal...
Ich bekomme ne Fehlermeldung
Fehler beim Kombilieren
Next ohne For
Ich hau dir mal komplett rein was bei mir unter cmdWeiter mit reingepackt ist.

Private Sub cmdWeiter_Click()
If txtDatum = "" Then MsgBox "Datum muss ausgefüllt werden!", vbCritical: Exit Sub
If cboUeberprueftVon = "" Then MsgBox "Überprüft von... muss ausgefüllt werden!",  _
vbCritical: Exit Sub
If txtRGNr = "" Then MsgBox "Rechnungsnummer muss ausgefüllt werden!", vbCritical: Exit Sub
If txtLFSNr = "" Then MsgBox "Lieferscheinnummer muss ausgefüllt werden!", vbCritical: Exit  _
Sub
erste_freie_Zeile2 = Sheets("HILFSTABELLE").Range("S65536").End(xlUp).Offset(1, 0).Row
Sheets("HILFSTABELLE").Cells(erste_freie_Zeile2, 20) = CDate(txtDatum)
Sheets("HILFSTABELLE").Cells(erste_freie_Zeile2, 21) = txtRGNr
Sheets("HILFSTABELLE").Cells(erste_freie_Zeile2, 22) = cboUeberprueftVon
Dim wsTmp As Worksheet, lngZ As Long, vntTmp, lngRow As Long, blnFound As Boolean
Set wsTmp = Worksheets.Add 'später löschen, wenn nicht mehr gebraucht
wsTmp.Name = "Rechnungen"
With Worksheets("BPF")
vntTmp = .Range("a1").CurrentRegion
For lngRow = 2 To UBound(vntTmp)
If vntTmp(lngRow, 43) = txtLFSNr Or vntTmp(lngRow, 55) = txtLFSNr Then
.Rows(lngRow).Copy wsTmp.Cells(1, 1)
blnFound = True
Exit For
Next lngRow
End With
If Not blnFound Then MsgBox "LS nicht gefunden"
Call SortierenRechnungen
Worksheets("BPF").ShowAllData
Worksheets("ÜBERSICHT").Select
Unload Me
UserForm7_Rechnung_Eintragen.Show
'Call LFSNr_Überprüfen
End Sub


Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige