Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1452to1456
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
Inhaltsverzeichnis

Ort aus Postleitzahl braucht zu viele Ressourcen

Ort aus Postleitzahl braucht zu viele Ressourcen
01.11.2015 20:31:30
Sabrina
Hallo Leute.
Ich habe folgende Methode als "Private Sub Worksheet_Change(ByVal Target As Range)"
Das Problem ist dass zu viele Ressourcen verbraucht werden.
Da ja bei jeder Eingabe in einem Feld die Methode ausgeführt wird.
Hat jemand eine Idee wie man dies effektiver lösen kann?
Ich habe noch andere dinge in der Methode drinnen ... es dauert leider sehr lange.
Hier die Test Datei
https://www.herber.de/bbs/user/101179.xls
Gruß Sabbel
Hier die Methode

Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim ort_wahl As Long
ort_wahl = Range("ort_wahl")
' Ort suche
Application.EnableEvents = True
Dim arr As Variant
Dim iCounter, Zähler As Long
If Not Target.Address(0, 0) = "PLZ" Then
If Not Intersect(Target, Range("PLZ")) Is Nothing Then
If Range("ORT_wahl") = 3 Then
Exit Sub
Else
Range("PLZ_wahl") = 3
UF1.ListBox1.Clear
arr = Workbooks("PLZ.xls").Worksheets("ORT").Range("B2").CurrentRegion.Value
For iCounter = 1 To UBound(arr)
If UCase(arr(iCounter, 2)) = UCase(Target) Then
UF1.ListBox1.AddItem arr(iCounter, 3)
Zähler = Zähler + 1
End If
Next
If Zähler = 0 Then
MsgBox " Diese PLZ existiert nicht"
Range("A4").ClearContents
Exit Sub
End If
If Zähler = 1 Then
Range("Ort").Value = UF1.ListBox1.List
Else
UF1.Show
End If
End If
End If
End If
' PLZ suche
If Not Intersect(Target, Range("Ort")) Is Nothing Then
If Range("PLZ_wahl") = 3 Then
Exit Sub
Else
Range("ort_wahl") = 3
UF2.ListBox1.Clear
arr = Workbooks("PLZ.xls").Worksheets("ORT").Range("A2").CurrentRegion.Value
For iCounter = 1 To UBound(arr)
If UCase(arr(iCounter, 1)) = UCase(Target) Then
UF2.ListBox1.AddItem arr(iCounter, 2)
Zähler = Zähler + 1
End If
Next
If Zähler = 0 Then
MsgBox " Dieser Ort existiert nicht"
Range("B4").ClearContents
Exit Sub
End If
If Zähler = 1 Then
Range("PLZ").Value = UF2.ListBox1.List
Else
UF2.Show
End If
End If
End If
Application.EnableEvents = True
End Sub

6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Grundsätzliche Möglichkeiten wären, ...
01.11.2015 21:02:25
Luc:-?
…Sabrina:
1. Die Adressen der Eingaben sammeln und erst auf Button-Click die Orte zu den PLZ an diesen Adressen raussuchen (hält dann die DatenEingabe kaum auf);
2. Das Suchpgm mit einer rationalen Suchstrategie auf der Basis von Suche in (dafür geeigneten) Datenfeldern, nicht ZellBereichen, zu versehen (denke dabei an die Strategien von schnellen Sortier­Routinen wie zB QuickSort → Teilmengen der Suchdaten je nach PLZ bilden).
Gruß, Luc :-?
Besser informiert mit …

Anzeige
warum nicht Excel-Suche?
02.11.2015 19:57:13
Michael
Hi zusammen,
ich habe mal ein bißchen gebastelt: die "Zwischenergebnisse" sind noch in der Datei, jeweils mit "Z" am Ende des Namens.
Beim Testen bin ich aber darübergestolpert, daß es eigentlich unschön aussieht, wenn man in den UFs nur je die PLZen *oder* die Orte angezeigt bekommt, so daß ich den neuesten Stand mit nur einer UF realisiert habe, bei der beides angezeigt und vor dem Zurückschreiben in die Tabelle wieder in PLZ/Ort zerlegt wird.
Der Code:
Option Explicit
Sub ev_ein()
' nur zum Einschalten der Events, falls man in der Testphase
' vorzeitig abgebrochen hat und das noch auf false steht
Application.EnableEvents = True
End Sub
Function listboxFuellen(ByRef lb As Object, r As Range, sb As Variant, spalte As Long,  _
zeileOffset) As Long
' wie Herber:
'https://www.herber.de/mailing/vb/html/xlmthfindx.htm
Dim c As Range, firstAddress As String
Dim gefunden As Long
With r
Set c = .Find(sb, LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
'         MsgBox .Cells(c.Row + zeileOffset, spalte).Value
gefunden = gefunden + 1
lb.AddItem .Cells(c.Row + zeileOffset, spalte).Value & _
" ! " & .Cells(c.Row + zeileOffset, spalte + 1).Value
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address  firstAddress
End If
End With
listboxFuellen = gefunden
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
Dim was As String, such As Variant
Dim wo As Range
Dim gefunden As Long
'Stop
If Not Intersect(Target, Range("PLZ")) Is Nothing Then
was = "Ort"
Else
If Not Intersect(Target, Range("Ort")) Is Nothing Then
was = "PLZ"
Else
Exit Sub
End If
End If
UF1.ListBox1.Clear
such = Target.Value
Set wo = Worksheets(2).Range("A2").CurrentRegion
' hier die komplette Angabe mit plz.xls
gefunden = listboxFuellen(UF1.ListBox1, wo, such, 1, -1)
If gefunden = 0 Then
MsgBox " zu Ihrer Eingabe " & such & " wurde nichts gefunden."
Exit Sub
End If
Application.EnableEvents = False
If gefunden = 1 Then
Range("Ort").Value = Split(UF1.ListBox1.List(0), " ! ")(1)
Range("PLZ").Value = Split(UF1.ListBox1.List(0), " ! ")(0)
Else
UF1.Show  ' dort auch kleine Änderungen für die Übernahme!
End If
Application.EnableEvents = True
End Sub
Die Datei: https://www.herber.de/bbs/user/101191.xls
Die Geschichte mit dem ZeilenOffset ist ne Krücke, die wegen Deiner Angabe ab der 2. Zeile nötig ist; das *könnte* man eleganter gestalten, aber ich habe jetzt keine Zeit mehr, mich da reinzuwurschteln.
Das Befüllen der Listbox habe ich in eine Function ausgelagert, um nicht mehrmals das Gleiche für die zwei ursprünglichen UFs schreiben zu müssen; wenn man nur eine verwendet, ist das eigentlich Quatsch, und man *könnte* die Funktionalität wieder in die aufrufende Sub integrieren...
Die Function ist ein schönes Beispiel für eine Variablenübergabe "ByRef", d.h. im Gegensatz zum standardmäßigen ByVal wird sie (die Listbox) innerhalb der Function mit Werten befüllt und steht bei der Rückkehr zur aufrufenden Sub mit geänderten Werten zur Verfügung.
Schöne Grüße,
Michael
P.S.: ich sehe grade, daß die If am Anfang, mit dem Intersect, eigentlich auch wieder vereinfacht werden kann, weil die Variable "wo" nirgends mehr ausgewertet wird - egal, es funktioniert ja.
Aber: ich habe die Logik Deines Originals dahingehend geändert, daß schlicht nach dem gesucht wird, was zuletzt eingegeben wurde, egal ob Ort oder PLZ.

Anzeige
AW: warum nicht Excel-Suche?
05.11.2015 23:00:29
Sabrina
Hallo Michael,
vielen Dank für deine Mühe.
Was ich in meine Datei nicht eingebunden bekomme ist dass meine Postleitzahlen und Orte in einer seperaten Datei ist (sein muss). Der Name der Datei lautet PLZ.xls.
Was meinst du denn mit dem Lezten Satz?

Aber: ich habe die Logik Deines Originals dahingehend geändert, daß schlicht nach dem gesucht wird, was zuletzt eingegeben wurde, egal ob Ort oder PLZ.
Liebe Grüße
Sabbel

AW: warum nicht Excel-Suche?
06.11.2015 12:35:07
Michael
Hi Sabrina,
lad bitte mal eine abgespeckte Datei der PLZ.xls hoch, dann baue ich's ein.
Der besagte Satz bezog sich auf Deine Logik (ich meine, in Spalte A, so in den Zeilen 7 und 8 oder so), wo Du 1 oder 3 geschrieben bzw. im Makro ausgewertet hast - das habe ich dadurch ersetzt, daß nach der jeweils letzten Eingabe gesucht wird. Kann natürlich sein, daß ich das falsch interpretiert habe.
Schöne Grüße,
Michael

Anzeige
AW: warum nicht Excel-Suche?
07.11.2015 10:00:46
Michael
Hi Sabbel,
ich würde an Deiner Stelle keine email-Adresse hier hereinschreiben - das könnte zu Spam führen.
Also: ich habe das Makro an Deine PLZ.xls angepaßt, außerdem die Makros in PLZ auskommentiert: solange Du nur lesend darauf zugreifst, ist es Quatsch, die immer automatisch beim Verlassen zu speichern.
Das Makro erfordert, daß die PLZ.xls geöffnet ist.
Wenn Du möchtest, daß sie automatisch bei Bedarf geöffnet wird bzw. daß überprüft wird, ob sie schon geöffnet ist oder nicht, laß Dich von Herbers XLfaqs inspirieren: https://www.herber.de/xlfaq/index.html
und hier insbesondere: https://www.herber.de/mailing/Pruefen_ob_Arbeitsmappe_geoeffnet_und_wenn_nein_oeffnen.htm
Deine Datein: https://www.herber.de/bbs/user/101302.zip
Schöne Grüße,
Michael
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige