So funktioniert JustAnswer:

  • Fragen Sie einen Experten
    Tausende Experten in über 200 Kategorien.
  • Erhalten Sie eine professionelle Antwort
    Per E-Mail oder sofortiger Benachrichtigung, während Sie auf unserer Website warten.
    Stellen Sie ggf. weitere Anschlussfragen.
  • 100%ige Zufriedenheit garantiert
    Bewerten Sie die erhaltene Antwort.

Stellen Sie Ihre Frage an MKruse.

MKruse
MKruse, Dipl.-Inform.
Kategorie: Computer
Zufriedene Kunden: 25
Erfahrung:  9 Jahre Erfahrung mit Java, VBA, Perl, C# und C++.
39215291
Geben Sie Ihre Frage in der Kategorie Computer hier ein
MKruse ist jetzt online.

Makro-Programmierung in Excel 2007 Entfernungsberechnung zwischen

Kundenfrage

Makro-Programmierung in Excel 2007: Entfernungsberechnung zwischen PLZ-Bereichen
Gepostet: vor 6 Jahren.
Kategorie: Computer
Experte:  it-pro hat geantwortet vor 6 Jahren.
Guten Tag. Ich denke, wir hatten bereits das Vergnügen. Meine Lösung mit dem Add-On hatte damals nicht bei Ihnen funktioniert. Bitte senden Sie mir Ihre aktuelle Fassung der Datei. Ich werde sehen, was ich tun kann. Email: [email protected]

Ich werde allerdings erst morgen dazu kommen, die Datei zu bearbeiten. Ist das ok für Sie?

Viele Grüße
Kunde: hat geantwortet vor 6 Jahren.
Hallo!

Sie können gerne noch einmal versuchen mein Problem zu lösen:

Inkl. der empfohlenen Anpassungen funktioniert das unten stehende Makro in Excel 2007 nicht. Es wird zwar der Internet-Explorer aufgerufen und die Entfernungen zwischen den gewünschten Orten abgefragt - die Kilometer werden aber NICHT in der Excel-Datei angezeigt!

Ich brauche eine Excel Datei mit zwei Spalten für die PLZs - und in der dritten Spalte die Angabe zu den Kilometer-Entfernungen zwischen den PLZ-Mittelpunkten.

Perfekt wäre das Makro, wenn es die GENAUE Kilometer-Entfernung zwischen zwei Adressen ermitteln könnte - aber damit rechne ich schon gar nicht mehr.

Ich verwende folgenden Makro:

Option Explicit

Sub Entfernung()
Dim IEApp As Object
Dim IEDocument As Object
Dim blnGefunden As Boolean
Dim RouteStr As String
Dim von As String
Dim nach As String
Dim Von_PLZ As String
Dim Nach_PLZ As String
Dim Von_Ort As String
Dim Nach_Ort As String
Dim Von_Straße As String
Dim Nach_Straße As String
Dim iedoc As Object
Dim strTeile As Variant
Dim i As Long
Dim msg As String
Dim tel As String
Dim anzahl As Long

blnGefunden = False

Von_Straße = Cells(4, 1)
Von_PLZ = Cells(4, 2)
Von_Ort = Cells(4, 3)

Nach_Straße = Cells(4, 4)
Nach_PLZ = Cells(4, 5)
Nach_Ort = Cells(4, 6)


von = Adresse(Von_Straße, Von_Ort, Von_PLZ)
nach = Adresse(Nach_Straße, Nach_Ort, Nach_PLZ)
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = False
IEApp.Navigate "http://maps.google.com/maps?saddr=" & von & "&daddr=" & nach & "&hl=de"
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False

Set IEDocument = IEApp.Document
Do: Loop Until IEDocument.ReadyState = "complete"

Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Set IEDocument = IEApp.Document
Do: Loop Until IEDocument.ReadyState = "complete"
Set iedoc = IEApp.Document

Do: Loop Until IEApp.Busy = False
strTeile = Split(iedoc.body.innertext, vbCrLf)
For i = LBound(strTeile) To UBound(strTeile)
If InStr(1, strTeile(i), "Minuten", vbTextCompare) > 0 Then
blnGefunden = True
msg = "Von: " & von & vbNewLine & "Nach: " & nach & vbNewLine & strTeile(i)
Debug.Print strTeile(i)
Debug.Print i
End If
Next
If blnGefunden = False Then
MsgBox "Die Adresse konnte nicht decodiert werden." & vbCr & "Falsche PLZ?"
Else
tel = strTeile(66)
anzahl = Len(tel)
Cells(8, 4) = Left(tel, anzahl - 17)

MsgBox strTeile(66)
MsgBox msg
End If
IEApp.Quit
Set IEDocument = Nothing
Set IEApp = Nothing
End Sub

Function Adresse(Street As String, City As String, ZIP As String) As String
Dim HStr As String

If Street <> "" Then HStr = Street & ","
If ZIP <> "" Then HStr = HStr & ZIP & " "
If City <> "" Then HStr = HStr & City
Adresse = Trim(HStr)
End Function

Ich verwende die Excel-Datei aus http://www.office-loesung.de/ftopic279644_45_0_asc.php#1516845.

Können Sie das Makro mit Excel-2007 zum laufen bringen und mir die Datei zum Download bereitstellen?
Experte:  xxx hat geantwortet vor 6 Jahren.
Guten Tag !
Vielen Dank für Ihre Anfrage. Ich hoffe sehr, Ihnen bei der Lösung Ihres Problems behilflich sein zu können.


Offensichtlich hat der Versuch mit der anderen Formel ja nicht geklappt. Die Methode über das Makro ist sicherlich der sinnvollste Weg. Falls das aber wider Erwarten nicht klappen sollte, bleibt noch der Wechsel der Geodaten. Melden Sie sich einfach nochmal, falls Sie diesen Weg dann auch noch ausprobieren wollen.

Ansonsten schönen Abend/Tag noch und viel Erfolg mit dem Makro.
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

die bisher gegebenen Ansätze in den gestellten Fragen sehen sehr vielversprechend aus. Ich denke der Weg über Geo-Koordinaten ist richtig. Es gibt jedoch Fehler in der Umrechnung Koordinaten -> Entfernung. Im dreidimensionalen Raum funktioniert die einfache Variante nicht, da die Drehungen sozusagen nacheinander erfolgen.
Die Lösung dazu heißt Quaternionen. Dies ist eine oft verwendete Technik in der Computergraphik. Leider hatte ich dies in meinem Studium nur beiläufig und das ist auch schon was her. Ich müsste mich daher erst wieder in das Thema einlesen. Ich bitte daher um etwas Geduld.
Mit Makros kenne ich mich gut aus. Wenn einer der Experten mir bei den mathematischen Grundlagen behilflich sein will, wäre ich auch bereit bei Erfolg die "Belohnung" zu teilen.
Eine weitere Möglichkeit bietet evtl. die GoogleMaps-API, für die Sie jedoch einige Voraussetzungen erfüllen müssten (freie Zugänglichkeit etc.). Sie können sich HIER über die API informieren und mir mitteilen, ob dies überhaupt als Alternative in Frage kommen könnte, bevor wir darauf Zeit verwenden im Falle eines Fehlschlags mit den Quaternionen.

MfG
M Kruse
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

also ich bin dann doch über die GoogleMaps-API gegangen, da Sie das eh vor hatten. Folgender Code tut bei mir das gewünschte. Evtl. müsste man diesen noch nach ihren Bedürfnissen anpassen, denn im Moment läuft er nur, wenn in der ersten Spallte die "Von" Postleitzahl und in der zweiten Spalte die "Nach" Postleitzahl steht und sonst nichts anderes (abgesehen von den Ergebnissen natürlich). Evtl. müsste man die Funktionen noch an Überschriften, bestimmtes Worksheet oder ähnlichem anpassen.
Außerdem berechnet dieses Makro nicht die Luftlinie, wie in den andere Fragen gefordert, sondern die Fahrtroute. Bei dem Ergebnis 0 wurde keine korrekte Postleitzahl angegeben.

Option Explicit


Private Function RealUsedRange() As Range

Dim FirstRow As Long
Dim LastRow As Long
Dim FirstColumn As Integer
Dim LastColumn As Integer

On Error Resume Next

FirstRow = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).row

FirstColumn = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column

LastRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

LastColumn = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set RealUsedRange = Range(Cells(FirstRow, FirstColumn), Cells(LastRow, LastColumn))

On Error GoTo 0

End Function

Private Function GetDistance(IEApp As Object, FromPLZ As String, ToPLZ As String) As String
Dim IEDocument As Object
Dim blnGefunden As Boolean
Dim iedoc As Object
Dim strTeile As Variant
Dim i As Long
Dim strTeil As Variant

blnGefunden = False

IEApp.Navigate "http://maps.google.com/maps?saddr=" & FromPLZ & "+Deutschland&daddr=" & ToPLZ & "+Deutschland&hl=de"
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Set IEDocument = IEApp.Document
Do: Loop Until IEDocument.ReadyState = "complete"
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Set IEDocument = IEApp.Document
Do: Loop Until IEDocument.ReadyState = "complete"
Set iedoc = IEApp.Document
Do: Loop Until IEApp.Busy = False

strTeile = Split(iedoc.body.innertext, vbCrLf)

For i = LBound(strTeile) To UBound(strTeile)
If InStr(1, strTeile(i), "Route nach", vbTextCompare) > 0 And blnGefunden <> True Then
blnGefunden = True
strTeile = Split(CStr(strTeile(i + 1)), " ")
GetDistance = CStr(strTeile(0))
GoTo DONE
End If
Next

If blnGefunden = False Then
GetDistance = "NA"
End If

DONE:
Set IEDocument = Nothing
End Function

Sub Entfernung()
Dim IEApp As Object
Dim UsedRange As Range
Dim row As Range
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = False

Set UsedRange = RealUsedRange()
For Each row In UsedRange.Rows
row.Cells(1, 3).Value = GetDistance(IEApp, CStr(row.Cells(1, 1)), CStr(row.Cells(1, 2)))
Next row

IEApp.Quit
End Sub


Eine ExcelDatei mit den entsprechenden Funktionen finden sie HIER. Ich hoffe ich konnte ihnen damit helfen. Bei weiteren Anpassungswünschen oder Problemen bin ich gerne weiterhin behilfreich. Wenn Sie zufrieden sind, dann würde ich mich über eine Akzeptierung der Antwort und eine positive Bewertung freuen.

Bitte beachten Sie, dass sie über GoogleMaps nur ca 2500 Anfragen am Tag machen dürfen. Sollten Sie mehr als diese Anzahl benötigen, so müssten Sie einen Premium-Dienst bei Google kaufen.

MfG
M Kruse

PS: Der Weg über Quaternionen war wohl doch etwas über das Ziel hinaus geschossen. Theoretisch funktioniert es und wäre evtl. der stabilere Weg, aber das würde doch etwas mehr Entwicklungs-Zeit verbrauchen. Die vom Kollegen Physikus vorgeschlagene Haversine-Funktion hätte aber eigentlich auch funktionieren müssen.
Kunde: hat geantwortet vor 6 Jahren.
Hallo!

Vielen Dank für Ihren Einsatz! Die API-Lösung ist eine sehr gute Idee und kann gut von uns verwendet werden.

Leider funktioniert das Makro aber nicht:

Laufzeitfehler '-2147467259 (80004005)':
Die Methode 'Busy' für das Objekt 'IWebBrowser2' ist fehlgeschlagen

Könnten Sie nocheinmal schnell die Spaltenüberschriften überprüfen? Evtl. liegt auch ein anderes Problem vor.

Wichtig: ich brauche ein funktionierendes Sheet für Excel 2007.

Vielen Dank!

MfG
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

also mir ist auch grade aufgefallen, dass sie von mehreren tausend Zeilen reden. Dies könnte ein Problem werden, da die Berechnung der Route recht viel Zeit benötigt und damit ein PLZ-Paar ca. 2 Sekunden benötigt. Evtl. bleibt, wenn es zeitkritisch wird, nichts anderes übrig, als doch über Längen und Breitengrade zu gehen. Dies müsste theoretisch schneller und auf jeden Fall zuverlässiger sein. Leider kann ich mich damit erst heute Abend beschäftigen.
Trotzdem vorerst nochmal zurück zum bestehenden System. Ist ihr Internetexplorer geöffnet? Wenn ja, dann schließen Sie diesen bitte. Der Fehler 80004005 deutet darauf hin, dass das Makro keinen Zugriff auf den Internetexplorer bekommen hat. Dies ist z.B. auch möglich, wenn Sicherheitsbestimmungen dies verhindern. Evlt. (da bin ich mir jedoch unsicher) könnte es helfen Excel als Administrator zu öffnen und anschließend die Datei (sofern Sie unter Vista oder höher arbeiten).
Arbeiten Sie generell mit dem Internetexplorer? Wenn nicht, dann öffnen Sie diesen bitte und richten ihn "komplett" ein (Meldungen wegen Standartbrowser abschalten, Updates und Plugins installieren). Wenn Sie es schaffen die Addresse http://maps.google.de/maps?&saddr=53343&daddr=50321ohne irgendeine Meldung vom IE aufzurufen, sollte zumindest dieser bereit sein.

Haben Sie dieses Makro in der Excel-Datei getestet, die ich ihnen "geschickt" hatte? Dort sollten ja keine Spaltenüberschriften vorhanden sein. Ich könnte das Script so anpassen, dass es nur auf den selektierten Spalten und Zeilen arbeitet oder einen Bereich von Ihnen abfragt.

MfG
M Kruse
Experte:  it-pro hat geantwortet vor 6 Jahren.
So. Ich habe das Makro etwas angepasst: Message-Boxen werden nicht mehr eingeblendet, die km werden in Spalte 7 eingetragen. Bitte beachten Sie, dass in Spalte 2 und 5 die PLZ eingetragen werden müssen. Spalte 1 und 4 stehen für Straßen inkl. Hausnummern zur Verfügung, Spalte 3 und 6 für Ortsnamen (jeweils Start- und Zieladressangaben).

Wichtig: In dieser groben Fassung des Makros muss im Quelltext die Nummer der letzten gefüllten Zeile manuell angegeben werden. Ich kann das aber gerne noch anpassen. Ansonsten geben Sie bitte an der Stelle For s = 1 To 10 statt der 10 die tatsächliche Anzahl der Zeilen an. Momentan würde er nur die ersten 10 bearbeiten.


Option Explicit

Sub Entfernung()
Dim IEApp As Object
Dim IEDocument As Object
Dim blnGefunden As Boolean
Dim RouteStr As String
Dim von As String
Dim nach As String
Dim Von_PLZ As String
Dim Nach_PLZ As String
Dim Von_Ort As String
Dim Nach_Ort As String
Dim Von_Straße As String
Dim Nach_Straße As String
Dim iedoc As Object
Dim strTeile As Variant
Dim i As Long
Dim msg As String
Dim tel As String
Dim anzahl As Long
Dim s As Long
s = 1
For s = 1 To 10
blnGefunden = False

Von_Straße = Cells(s, 1)
Von_PLZ = Cells(s, 2)
Von_Ort = Cells(s, 3)

Nach_Straße = Cells(s, 4)
Nach_PLZ = Cells(s, 5)
Nach_Ort = Cells(s, 6)


von = Adresse(Von_Straße, Von_Ort, Von_PLZ)
nach = Adresse(Nach_Straße, Nach_Ort, Nach_PLZ)
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = False
IEApp.Navigate "http://maps.google.de/maps?saddr=" & von & "&daddr=" & nach & "&hl=de"
Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False

Set IEDocument = IEApp.Document
Do: Loop Until IEDocument.ReadyState = "complete"

Do: Loop Until IEApp.Busy = False
Do: Loop Until IEApp.Busy = False
Set IEDocument = IEApp.Document
Do: Loop Until IEDocument.ReadyState = "complete"
Set iedoc = IEApp.Document

Do: Loop Until IEApp.Busy = False
strTeile = Split(iedoc.body.innertext, vbCrLf)
For i = LBound(strTeile) To UBound(strTeile)
If InStr(1, strTeile(i), "Minuten", vbTextCompare) > 0 Then
blnGefunden = True
msg = "Von: " & von & vbNewLine & "Nach: " & nach & vbNewLine & strTeile(i)
Debug.Print strTeile(i)
Debug.Print i
End If
Next
If blnGefunden = False Then
Cells(s, 7) = "Falsche PLZ?"
Else
tel = strTeile(67)
anzahl = Len(tel)
Cells(s, 7) = Left(tel, anzahl - 17)
End If
IEApp.Quit
Set IEDocument = Nothing
Set IEApp = Nothing
Next s
End Sub


Function Adresse(Street As String, City As String, ZIP As String) As String
Dim HStr As String

If Street <> "" Then HStr = Street & ","
If ZIP <> "" Then HStr = HStr & ZIP & " "
If City <> "" Then HStr = HStr & City
Adresse = Trim(HStr)
End Function
Experte:  it-pro hat geantwortet vor 6 Jahren.
Funktioniert es bei Ihnen? Falls ja, dann akzeptieren Sie bitte noch die Antwort. Vielen Dank XXXXX XXXXX Grüße.
Kunde: hat geantwortet vor 6 Jahren.
Leider funktioniert das Makro nicht: es werden immer nur die ersten beiden Adressen über den Internetexplorer/ Google Maps abgefragt - die Kilometer werden aber nicht in Spalte 7 eingetragen.

Das war auch bisher stets das Problem des Makro.

Funktioniert das Makro bei Ihnen mit Excel 2007 und dem Internetexplorer? Bitte machen Sie mir eine funktionierende Excel-2007 Datei zugänglich - sobald das Ding läuft, bezahle ich Sie gerne!

MfG
Experte:  it-pro hat geantwortet vor 6 Jahren.
Ja, das Makro funktioniert bei mir. Bitte senden Sie mir Ihre Email-Adresse [email protected]
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

wenn die Zusammenarbeit mit dem Herrn Kollegen nicht fruchten sollte, dann können Sie sich ja auch auf dem Wege hier nochmal bei mir melden. Ich passe mein Skript gerne ihren Bedürfnissen an. Funktionieren sollte es ja mittlerweile, oder nicht?

MfG und viel Erfolg an den Kollgen und ihnen
M Kruse
Kunde: hat geantwortet vor 6 Jahren.
Der Fairneß halber warte ich noch 1 Std. auf die Antwort-Email von it-pro - anschließend werde ich Sie bitten mir beim Makro zu helfen.

Vielen Dank für Ihr Angebot!
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

danke für die Chance und diese Fairness. Ich halte sowas auch für sehr wichtig und achte daher auch, diese Frist selbst einzuhalten und keine konkreten Vorschläge unterbreiten.

Nichts desto trotz wüsste ich gerne, ob die Excel-Datei sich mittlerweile ausführen lässt, wenn der Internetexplorer eingerichtet und geschlossen ist. Sonst würde ich mir Gedanken über weitere Schritte oder eine ganz andere Lösung machen.
Z.B. wäre es auch möglich ein kleines Programm zu schreiben, dass nicht den Internetexplorer benutzt. Dieses Programm müsste dann aber ersteinmal geschrieben werden und immer der Exceldatei beiliegen.

MfG
M Kruse.
Experte:  it-pro hat geantwortet vor 6 Jahren.
Email an den Fragesteller ist unterwegs. Falls die Lösung nicht den Vorstellungen entspricht, wird es an dieser Stelle bekannt gegeben.
Kunde: hat geantwortet vor 6 Jahren.
Hallo,
leider sehe ich in Ihrer Excel-Datei keinen Unterschied zu dem Makro, das ich kostenlos in einem Internet-Forum gefunden habe: nach Ausführung des Makros öffnet sich der Internetexplorer und fragt über Google-Maps die Kilometer-Entfernung zwischen den ersten beiden Adressen in der Liste ab, OHNE daß die Kilometer-Entfernung in die Excel-Datei übertragen werden würde:
Laufzeitfehler '-2147467259 (80004005)'
Die Methode 'Busy' für das Objekt 'IWebBrowser2' ist fehlgeschlagen
Ich verwende Windows Vista, Excel 2007 und den Internetexplorer 7 (Version 7.0.6001.18000). Entweder eignet sich das Makro nicht für die genannten Software-Versionen, oder der Fehler liegt irgendwo anders.
Haben Sie evtl. noch eine Idee zur Lösung des Problems?
MfG
Experte:  it-pro hat geantwortet vor 6 Jahren.
Guten Morgen. Ich habe das Makro unter Windows 7 mit Excel 2007 und dem IE 8 erstellt. Es wundert mich, dass es in Ihrer Umgebung nicht funktioniert.

An dem Makro habe ich im Grunde drei Sachen geändert: Die Message-Boxen tauchen nicht mehr auf, damit man nicht das Ergebnis jedes Datenabrufes einzeln bestätigen muss. Der String, der vom ursprünglichen Makro als Kilometerzahl in die Tabellenzelle eingetragen wurde, wurde vor der Änderung nicht an der korrekten Stelle abgegriffen und lieferte daher nur einen Textschnippsel von Google zurück. Zu guter Letzt habe ich eine Schleife eingebaut, um eine beliebige Anzahl von Zeilen innerhald der Tabelle abarbeiten zu lassen.

Vielleicht würde ein Update auf den IE 8 bereits Abhilfe bei Ihnen schaffen. Für den Fall, dass Sie keinen Versuch mit einem Update des IE 8 wünschen, werde ich bereits vorab den Experten DKM83 in Kenntnis darüber setzen, dass er möglicherweise einen anderen Lösungsansatz erarbeiten soll. Ich denke, dass Sie bereits Kontakt mit ihm hatten.

Falls Sie das Update durchführen und das Makro danach läuft, dann lassen Sie dies bitte DKM83 und mich wissen. Anderenfalls besprechen Sie die nächsten Schritte bitte direkt mit DKM83.

Viele Grüße
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo nochmal,

sehr schade, dass das Makro des Kollegen nicht funktioniert.
Gerne nehme ich das Problem in meine Hand.

Als Allererstes versuchen Sie sich bitte mit DIESER Exceldatei. Den Code dazu finden Sie am Schluss dieses Posts. Bitte verändern Sie dabei die Werte der Variablen "PLZVonSpalte", "PLZNachSpalte" und "ErgebnisSpalte" entsprechend ihren Bedürfnissen. Dabei ist gemeint, dass die Spalte A dem Wert 1 entspricht, B dem Wert 2 usw. Um das Makro direkt in der Exceldatei von mir zu testen, belassen Sie die Werte einfach so. Das Makro benötigt einiges an Ressourcen und läuft nicht wirklich schnell. Deshalb löschen Sie einfach ein paar Zeilen im Excel-Sheet zum Test. Für einen echten Durchlauf müssen Sie den Computer einfach nur "in Ruhe lassen" bis er fertig ist.

Sollte das Makro ebenfalls nicht funktionieren oder nicht ihren Bedürfnissen gerecht werden (insbesondere in Punkto Zeit), so gibt es wie angesprochen andere Lösungen, die unabhängig vom IE sind. Dafür müsste ich jedoch ein Programm schreiben, dass von einem Makro aus aufgerufen wird. Dies wird einige Zeit beanspruchen und wäre normalerweise sehr teuer. Da ich aber selber neugierig bin, ob ich eine adequate Lösung finden kann, würde ich einiges an Entwicklungszeit auf "meine Kappe" nehmen. Doch leider bin ich ab heute Nachmittag für einige Tage nicht erreichbar (Kurzurlaub). Ich könnte mich frühstens Montagnachmittag damit beschäftigen.
Wäre ein externes Programm, dass der Exceldatei immer beiligen müsste eine annehmbare Lösung für Sie?
Ich habe mein Makro übrigens auch unter Office 2007, Vista und IE 7 entwickelt. Von daher scheint ein Update auf IE 8 nicht unbedingt zur Lösung beizutragen, aber wäre nichts desto trotz sinnvoll, da der IE 7 einige Sicherheitslücken aufweist. Ich benutze den IE 7 nur zu Supportzwecken.

Wenn Sie mit meinem Ansatz zur Lösung des Problems und der Verzögerung einverstanden sind, bitte ich Sie mir eine Beispieltabelle zuzusenden, die verfälschte Daten enthält.
Außerdem würde ich gerne wissen, wieviele Einträge Sie in der Regel mit einem Durchlauf bearbeiten müssten.
Desweiteren wüsste ich gerne, ob Sie die Routen- oder Luftlinienlänge als Angabe bevorzugen würden, wobei Luftlinie wesentlich schneller zu berechnen wäre, aber evtl nicht immer für Sie praktikabel ist.

Die benötigten Informationen können Sie an kruse (at) uni-bonn.de senden.

MfG
M Kruse

Und nun zur Sicherheit nochmal der Code von dem veränderten Makro:

Option Explicit


Private Function RealUsedRange() As Range

Dim FirstRow As Long
Dim LastRow As Long
Dim FirstColumn As Integer
Dim LastColumn As Integer

On Error Resume Next

FirstRow = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).row

FirstColumn = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column

LastRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

LastColumn = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set RealUsedRange = Range(Cells(FirstRow, FirstColumn), Cells(LastRow, LastColumn))

On Error GoTo 0

End Function

Private Function GetDistance(IEApp As Object, FromPLZ As String, ToPLZ As String) As Double
Dim IEDocument As Object
Dim blnGefunden As Boolean
Dim strTeile As Variant
Dim i As Long
Dim strTeil As Variant

blnGefunden = False

IEApp.Navigate "http://maps.google.com/maps?saddr=" & FromPLZ & "+Deutschland&daddr=" & ToPLZ & "+Deutschland&hl=de" 'Sende ein Anfrage an GoogleMaps mit den beiden Postleitzahlen und Deutschland zur Eingrenzung
Do: Loop Until IEApp.Busy = False 'Warte
Do: Loop Until IEApp.Busy = False 'Warte
Set IEDocument = IEApp.Document 'Hol das Dokument
Do: Loop Until IEDocument.ReadyState = "complete" 'War die Anfrage erfolgreich
Do: Loop Until IEApp.Busy = False 'Warte
Do: Loop Until IEApp.Busy = False 'Warte
Set IEDocument = IEApp.Document 'Hol das Ergebnis

strTeile = Split(IEDocument.body.innertext, vbCrLf) 'Splitte die einzelnen Zeilen

For i = LBound(strTeile) To UBound(strTeile) 'Für jede Zeile:
If InStr(1, strTeile(i), "Route nach", vbTextCompare) > 0 And blnGefunden <> True Then 'Suche nach "Route nach". Die darauffolgende Zeile enthält das gesuchte Ergebnis
blnGefunden = True
strTeile = Split(CStr(strTeile(i + 1)), " ")
GetDistance = CDbl(strTeile(0)) 'Der erste Splitpart (nach Leerzeichen gesplittet) der Folgezeile enthält das Ergebnis
GoTo DONE
End If
Next

If blnGefunden = False Then
GetDistance = 0
End If

DONE:
Set IEDocument = Nothing
End Function

Private Function IsZahl(number As Object) As Boolean
If VarType(number) = vbInteger Or VarType(number) = vbDouble Then
IsZahl = True
Else
IsZahl = False
End If
End Function

Sub Entfernung()
Dim IEApp As Object
Dim UsedRange As Range
Dim row As Range
Dim PLZVonSpalte As Integer
Dim PLZNachSpalte As Integer
Dim ErgebnisSpalte As Integer
Dim vonValue As Object
Dim nachValue As Object

PLZVonSpalte = 1 'Diesen Wert auf die PLZ-Von Spalte setzen, wobei A = 1, B = 2 usw entspricht
PLZNachSpalte = 2 'Diesen Wert auf die PLZ-Nach Spalte setzen
ErgebnisSpalte = 3 'Diesen Wert auf die Ergebnis Spalte setzen

Set IEApp = CreateObject("InternetExplorer.Application") 'Erstelle ein InternetExplorer-Objekt
IEApp.Visible = False

Set UsedRange = RealUsedRange() 'Ermittle die Zeilen und Spalten, die wirklich Werte enthalten
For Each row In UsedRange.Rows 'Für jede Zeile im benutzen Bereich
If row.Cells(1, ErgebnisSpalte).Value = "" Then 'Nur wenn das Ergebnisfeld leer ist
Set vonValue = row.Cells(1, PLZVonSpalte)
Set nachValue = row.Cells(1, PLZNachSpalte)
If IsZahl(vonValue) And IsZahl(nachValue) Then 'Sind die Postleitzahlen gültige Zahlen?
row.Cells(1, ErgebnisSpalte).Value = GetDistance(IEApp, CStr(vonValue), CStr(nachValue)) 'Hol die Entfernung und speicher diese
End If
End If
Next row

IEApp.Quit
Set IEApp = Nothing
End Sub
Kunde: hat geantwortet vor 6 Jahren.
Wir sind zu 99% an der Lösung dran!

ENDLICH funktioniert das Makro! Jetzt brauchen wir nur noch eine klitzekleine Änderung: wäre es möglich daß Makro so zu verfassen, daß es die Entfernung einer vollständigen Adresse berechnen kann (so wie im Makro Ihres Konkurrenten/ Kollegen)?

Excel-Sheet mit folgenden Spalten: Straße, PLZ, Ort; Straße, PLZ, Ort, Entfernung

Königstraße 4, 70173, Stuttgart; Mainzer Landstr. 47, 60329, Frankfurt am Main, 204km

Wenn Sie das noch hinbekommen, erhöhen wir einfach den Betrag von 38 EUR auf 50 EUR zur Beantwortung dieser Frage.

Vielen Dank!

MfG
Experte:  MKruse hat geantwortet vor 6 Jahren.
Klar kein Problem. Ich melde mich sobald ich fertig bin.
Kunde: hat geantwortet vor 6 Jahren.
Alles klar - vielen Dank!
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

schon fertig. Ich muss sagen, dass ich die Methode des Makros selbst nicht 100% mag. Es sucht auf der Seite von GoogleMaps nach "Route nach" und nimmt die Folgezeile des als gesuchtes Ergebnis. Wenn Google etwas daran ändert, dann müsste man es anpassen. Doppeldeutigkeiten oder ähnliches könnten das Makro auch etwas aus dem Gleichgewicht bringen. Immerhin überprüft das Makro, ob sich in der PLZ-Spalte auch wirklich Zahlen befinden.
Bei ungültigen Postleitzahlen bleibt die km-Spalte leer und bei einer Addresse, die keine erwartete Google-Seite zurücklieferte, trägt das Makro eine -1 ein.
Zeilen, die bereits km-Werte enthalten, werden nciht neu berechnet. Ändert sich die Addresse, so müssen sie daran denken die km-Werte zu löschen. Dafür werden aber halt keine anderen doppelt berechnet.
Das Makro in Excel-Form gibt es HIER und auch im Anschluss.

Sie brauchen übrigens den Wert der Frage nicht erhöhen, sondern können auch einen Bonus zahlen. Aber vielleicht unterliege ich da auch grade einem Missverständnis und sie meinten das auch.

Bitte melden Sie sich, wenn es weitere Probleme gibt.

MfG
M Kruse

Option Explicit


Private Function RealUsedRange() As Range

Dim FirstRow As Long
Dim LastRow As Long
Dim FirstColumn As Integer
Dim LastColumn As Integer

On Error Resume Next

FirstRow = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext).row

FirstColumn = Cells.Find(What:="*", After:=Range("IV65536"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext).Column

LastRow = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row

LastColumn = Cells.Find(What:="*", After:=Range("A1"), LookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

Set RealUsedRange = Range(Cells(FirstRow, FirstColumn), Cells(LastRow, LastColumn))

On Error GoTo 0

End Function

Private Function GetDistance(IEApp As Object, FromAddr As String, ToAddr As String) As String
Dim IEDocument As Object
Dim blnGefunden As Boolean
Dim strTeile As Variant
Dim i As Long
Dim strTeil As Variant

blnGefunden = False

IEApp.Navigate "http://maps.google.com/maps?saddr=" & FromAddr & "&daddr=" & ToAddr & "&hl=de" 'Sende ein Anfrage an GoogleMaps mit den beiden Postleitzahlen und Deutschland zur Eingrenzung
Do: Loop Until IEApp.Busy = False 'Warte
Do: Loop Until IEApp.Busy = False 'Warte
Set IEDocument = IEApp.Document 'Hol das Dokument
Do: Loop Until IEDocument.ReadyState = "complete" 'War die Anfrage erfolgreich
Do: Loop Until IEApp.Busy = False 'Warte
Do: Loop Until IEApp.Busy = False 'Warte
Set IEDocument = IEApp.Document 'Hol das Ergebnis

strTeile = Split(IEDocument.body.innertext, vbCrLf) 'Splitte die einzelnen Zeilen

For i = LBound(strTeile) To UBound(strTeile) 'Für jede Zeile:
If InStr(1, strTeile(i), "Route nach", vbTextCompare) > 0 And blnGefunden <> True Then 'Suche nach "Route nach". Die darauffolgende Zeile enthält das gesuchte Ergebnis
blnGefunden = True
strTeile = Split(CStr(strTeile(i + 1)), " ")
GetDistance = CStr(strTeile(0)) & " km" 'Der erste Splitpart (nach Leerzeichen gesplittet) der Folgezeile enthält das Ergebnis
GoTo DONE
End If
Next

If blnGefunden = False Then
GetDistance = "-1"
End If

DONE:
Set IEDocument = Nothing
End Function

Private Function IsZahl(number As Object) As Boolean
If VarType(number) = vbInteger Or VarType(number) = vbDouble Then
IsZahl = True
Else
IsZahl = False
End If
End Function

Function Adresse(Street As String, ZIP As String, City As String) As String
Dim HStr As String

If Street <> "" Then HStr = Replace(Street, " ", "+") & "+"
If ZIP <> "" Then HStr = HStr & ZIP & "+"
If City <> "" Then HStr = HStr & Replace(City, " ", "+")
Adresse = Trim(HStr)
End Function

Sub Entfernung()
Dim IEApp As Object
Dim UsedRange As Range
Dim row As Range
Dim ErgebnisSpalte As Integer

Dim StreetVonSpalte As Integer
Dim PLZVonSpalte As Integer
Dim CityVonSpalte As Integer

Dim StreetNachSpalte As Integer
Dim PLZNachSpalte As Integer
Dim CityNachSpalte As Integer

Dim vonSValue As Object
Dim vonZValue As Object
Dim vonCValue As Object

Dim nachSValue As Object
Dim nachZValue As Object
Dim nachCValue As Object

StreetVonSpalte = 1 'Diesen Wert auf die Straße-Von Spalte setzen, wobei A = 1, B = 2 usw entspricht
PLZVonSpalte = 2 'Diesen Wert auf die PLZ-Von Spalte setzen
CityVonSpalte = 3 'Diesen Wert auf die Stadt-Von Spalte setzen

StreetNachSpalte = 4 'Diesen Wert auf die Straße-Nach Spalte setzen
PLZNachSpalte = 5 'Diesen Wert auf die PLZ-Nach Spalte setzen
CityNachSpalte = 6 'Diesen Wert auf die Stadt-Nach Spalte setzen

ErgebnisSpalte = 7 'Diesen Wert auf die Ergebnis Spalte setzen

Set IEApp = CreateObject("InternetExplorer.Application") 'Erstelle ein InternetExplorer-Objekt
IEApp.Visible = False

Set UsedRange = RealUsedRange() 'Ermittle die Zeilen und Spalten, die wirklich Werte enthalten
For Each row In UsedRange.Rows 'Für jede Zeile im benutzen Bereich
If row.Cells(1, ErgebnisSpalte).Value = "" Then 'Nur wenn das Ergebnisfeld leer ist
Set vonSValue = row.Cells(1, StreetVonSpalte)
Set vonZValue = row.Cells(1, PLZVonSpalte)
Set vonCValue = row.Cells(1, CityVonSpalte)

Set nachSValue = row.Cells(1, StreetNachSpalte)
Set nachZValue = row.Cells(1, PLZNachSpalte)
Set nachCValue = row.Cells(1, CityNachSpalte)

If IsZahl(vonZValue) And IsZahl(nachZValue) Then 'Sind die Postleitzahlen gültige Zahlen?
row.Cells(1, ErgebnisSpalte).Value = GetDistance(IEApp, Adresse(CStr(vonSValue), CStr(vonZValue), CStr(vonCValue)), Adresse(CStr(nachSValue), CStr(nachZValue), CStr(nachCValue))) 'Hol die Entfernung und speicher diese
End If
End If
Next row

IEApp.Quit
Set IEApp = Nothing
End Sub
MKruse, Dipl.-Inform.
Kategorie: Computer
Zufriedene Kunden: 25
Erfahrung: 9 Jahre Erfahrung mit Java, VBA, Perl, C# und C++.
MKruse und weitere Experten für Computer sind bereit, Ihnen zu helfen.
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo nochmal,

ich wollte nur kurz nachfragen, ob alles zur Zurfriedenheit ist. Ich stehe jetzt nämlich in einer Stunde nochmal kurz zur Verfügung und dann erst Montagnachmittag.
Gibt es Probleme, so könnte ich mich in einer Stunde kurz damit beschäftigen, ansonsten melde ich mich am Montag sobald ich kann.

MfG
M Kruse
Experte:  MKruse hat geantwortet vor 6 Jahren.
Hallo,

ich bin aus dem Kurzurlaub zurück und stehe damit wieder zur Verfügung, wenn es nötig ist. Liefert das Makro bei Ihnen das gewünschte Resultat?

Wenn Sie zufrieden sind, dann möchte ich nochmal an die Akzeptierung der Antwort erinnern. Über eine positive Bewertung würde ich mich auch freuen.

MfG
M Kruse

Bekannt aus:

 
 
 
„[...]mehr als Zehntausend Experten weltweit; 1500 davon in Deutschland. Acht Jahre nach dem Start ist das [...] Online-Unternehmen mit seinen 90 Mitarbeitern die größte Web-Seite für das Vermitteln von Experten von Anwälten über Ärzte bis hin zu Universitätsprofessoren.“
„Wer eine fachmänische Lösung für ein medizinisches, rechtliches oder technisches Problem sucht, kann das jetzt auch im Internet tun. Lebenshilfe auf die schnelle, unkomplizierte und vor allem erschwingliche Art bietet die Seite www.justanswer.de. Etwa 1500 Experten stehen per Mail für Fragen zu ca. 200 Fachgebieten rund um die Uhr zur Verfügung."
„Rat gewünscht? Rechtliche, medizinische oder allgemeine Fragen beantworten Experten unter www.justanswer.de."
„JustAnswer, die weltweit führende Online-Plattform für Expertenfragen und -antworten, bietet ab sofort noch mehr Sicherheit und Qualität für Verbraucher."
„Ob Vorbereitung, Notfall oder Reklamation nach dem Urlaub - JustAnswer bietet jederzeit schnelle, kompetente Antworten"
„Die Online-Plattform JustAnswer bringt Ratsuchende und Experten in über 200 Fachgebieten zusammen."
 
 
 

Was unsere Besucher über uns sagen:

 
 
 
  • Ich bedauere, dass ich nicht gleich bei Ihnen gelandet bin. Die Leerung des Cache hat das Problem gelöst. Danke Gerd Schönbuchner Grafrath
< Zurück | Weiter >
  • Ich bedauere, dass ich nicht gleich bei Ihnen gelandet bin. Die Leerung des Cache hat das Problem gelöst. Danke Gerd Schönbuchner Grafrath
  • Endlich ein Experte, der mir wirklich weiterhelfen konnte! DANKE! JustAnswer Kunde Taunusstein
  • Ihre Antwort hat mir sehr geholfen, die richtigen Entscheidungen zu treffen. Dass Sie mir darüber hinaus noch 2 Empfehlungen gegeben haben fand ich super. Vielen Dank! JustAnswer Kunde Freiburg
  • Die ausgearbeiteten Hilfen waren gut strukturiert, leicht verständlich und zu 100% hilfreich für mich. Vielen Dank Markus B. Karlsruhe
  • Sehr schnelle und kompetente Antwort, die für mich bares Geld bedeutet. Vielen Dank! S.Stober K.
  • Herzlichen Dank! Hab durch Ihre Antwort viel Geld gespart! Ben R. Deutschland
  • Sehr schnelle und kompetente Hilfestellung. Besonders für mich als Laien wurde alles sehr verständlich erklärt. Gerne wieder! Rosengl Bad Tölz
 
 
 

Lernen Sie unsere Experten kennen:

 
 
 
  • Tronic

    Tronic

    IT-Specialist

    Zufriedene Kunden:

    2269
    Elektroniker und EDV-Service
< Zurück | Weiter >
  • http://ww2.justanswer.com/uploads/PY/Pyroflash/2011-4-21_104934_tronic.64x64.jpg Avatar von Tronic

    Tronic

    IT-Specialist

    Zufriedene Kunden:

    2269
    Elektroniker und EDV-Service
  • http://ww2.justanswer.com/uploads/rufushoschi/2010-11-08_135947_bild.jpg Avatar von IT-Fachinformatiker

    IT-Fachinformatiker

    Systemadministrator

    Zufriedene Kunden:

    6338
    Software Entwicklung, Projekt Erfahrung, Windows-Netzwerke, Linux-Netzwerke, Windows/Linux-Server
  • http://ww2.justanswer.com/uploads/COMINAROSA/2010-02-03_172238_PASSBILD.JPG Avatar von COMIN IT-Service

    COMIN IT-Service

    Dipl.-Ing.

    Zufriedene Kunden:

    779
    Dipl.Ing (FH) ET, NT, IT
  • http://ww2.justanswer.com/uploads/RaubergerConcep/2010-03-02_102740_Portraet64.jpg Avatar von RaubergerConcept

    RaubergerConcept

    IT-Specialist

    Zufriedene Kunden:

    234
    Mehr als 10 Jahre Erfahrung in Softwareentwicklung und Netzwerktechnik
  • http://ww2.justanswer.com/uploads/LF/lfalkenburg/2015-2-8_01843_.64x64.jpg Avatar von Lutz Falkenburg

    Lutz Falkenburg

    IT-Specialist

    Zufriedene Kunden:

    96
    Seit über 20 Jahren beruflich im IT-/IUK-Bereich tätig. Egal ob EinzelPC der Netzwerk...
  • http://ww2.justanswer.com/uploads/BI/BigDaddyXD/2012-10-24_20126_WhySoSeriousJob.64x64.jpg Avatar von BigDaddyXD

    BigDaddyXD

    Informatiker

    Zufriedene Kunden:

    1588
    Microsoft Certified Professional, Microsoft Certified Desktop Support Technican,...
  • http://ww2.justanswer.com/uploads/PU/Pucky80/2011-5-14_54537_pucky80.64x64.jpg Avatar von Pucky80

    Pucky80

    IT-Systemkaufmann

    Zufriedene Kunden:

    1322
    MCITP (Microsoft Server 2008 Enterprise Administrator)
 
 
 

Ähnliche Fragen in der Kategorie Computer