Live-Forum - Die aktuellen Beiträge
Datum
Titel
04.05.2024 16:03:54
Problem mit einer Regel bei bedingter Formatierung
04.05.2024 10:29:31
.Find(what:=..., Lookat:=xlWhole, LookIn:=xlValues) ->For
04.05.2024 09:44:33
Bestimmten bereich aus einem String per VBA separieren
04.05.2024 08:24:07
Sortieren und übertragen
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
1808to1812
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
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
1808to1812
1808to1812
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Luftlinie Berechnen

Luftlinie Berechnen
30.01.2021 18:44:51
Suysaler
Hallo,
Ich habe eine neue Aufgabe bekommen und wollte fragen ob ihr mir weiterhelfen könnt.
Ich muss aus diversen Adresse Also Start + Ziel = Luftlinie errechnen. Ich habe es mit diversen Makros versucht jedoch scheint es nicht zu klappen...
Ich habe auch hier im Forum etwas gefunden jedoch funktioniert das leider auch nicht..
Eine idee?

16
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Luftlinie Berechnen
30.01.2021 18:57:51
Suysaler
Danke Marc,
Leider nicht. Auf dieser Seite war ich auch schon jedoch geht das genauso nicht.
Ich habe hier im Forum ein Eintrag von 2013 gefunden.
https://www.herber.de/forum/archiv/1304to1308/1306053_Entfernungsberechnung_luftlinie.html
Genau das selbe Problem habe ich auch jedoch funktioniert es nicht...
Ich weiß nicht was das Problem da ist...
Vllt die Zellen? Ich habe auf einer neuen Arbeitsmappe genauso wie der Herr die Spalten dann genommen jedoch wird es trotzdem nicht ausgerechnet
Anzeige
AW: Luftlinie Berechnen
30.01.2021 19:05:11
ralf_b
die bieten eine Api an um Daten dort abzugreifen. aber die willst du nicht nutzen oder?
AW: Luftlinie Berechnen
30.01.2021 19:06:35
Suysaler
Nein, es sollte schon direkt durch die Excel-Liste die ich habe, berechnen. So wie es 2013 bereits der fall war...
AW: Luftlinie Berechnen
30.01.2021 19:08:15
ralf_b
webseiten verändern sich. Ach um genau solche Nutzung zu verhindern.
AW: Luftlinie Berechnen
30.01.2021 19:08:16
ralf_b
webseiten verändern sich. Ach um genau solche Nutzung zu verhindern.
AW: Luftlinie Berechnen
30.01.2021 18:52:09
Suysaler
Ganz vergessen zu erwähnen. Ich soll die Daten von der seite www.luftlinie.org errechnen...
AW: Luftlinie Berechnen
30.01.2021 19:05:27
Suysaler
Hier noch mal die Schleife:
Sub luftlinie_online_flexibel()
Zeilen = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
For schleife = 1 To Zeilen
Dim IEApp As Object, luftlinie As Object
Set IEApp = CreateObject("InternetExplorer.Application")
IEApp.Visible = False
IEApp.Navigate "http://www.luftlinie.org/" & Cells(schleife, 1) & "_" & Cells(schleife, 2)
Do: Loop Until IEApp.busy = False
Do: Loop Until IEApp.busy = False
Do: Loop Until IEApp.document.readyState = "complete"
Set luftlinie = IEApp.document.getElementById("airline")
If Not luftlinie Is Nothing Then
Cells(schleife, 3) = luftlinie.innertext
End If
IEApp.Quit
Set IEApp = Nothing
Next schleife
End Sub

Kann es vllt damit zusammen hängen das es nicht funkioniert, weil 'InternetExplorer' angewandt wird?
Anzeige
AW: Luftlinie Berechnen
30.01.2021 19:11:16
Oberschlumpf
man, man, auch wenn ich nerven sollte, ich frag auch dich!
Wieso zeigst du uns nur Code und nich per Upload gleich ne Bsp-Datei mit Bsp-Daten UND dem Code?
AW: Luftlinie Berechnen
30.01.2021 19:18:08
Suysaler
Weil ich nicht vor dem PC bin. Sonst hätte ich ein Upload gemacht.
AW: Luftlinie Berechnen
30.01.2021 20:04:54
volti
Hallo,
teste mal folgendes Makro. Vielleicht kannst Du es bei Erfolg in Deinem Sinne umbauen und verwenden:
Code:

Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Type DIST_STRUCT
     Start As String ' Mehrere durch "/" getrennt eingeben
     Ziel  As String
     LDist As String
     FDist As String
End Type
Sub EntfernungErmitteln()
  Dim tDist As DIST_STRUCT
  With tDist
      .Start = "Frankfurt": .Ziel = "München"           ' Zu suchende  Orte <<< anpassen >>>
      GetDistance tDist
      MsgBox "Die Entfernung zwischen" & vbCrLf _
      & .Start & vbCrLf & "und" & vbCrLf _
      & .Ziel & vbCrLf & "beträgt " & .LDist & " km." & vbCrLf _
      & "Die Fahrstrecke beträgt " & .FDist & "!", vbInformation, "Entfernung ermitteln"
  End With
End Sub
Sub GetDistance(tDist As DIST_STRUCT)
  Dim oNode As Object
  With CreateObject("InternetExplorer.Application")
      .navigate "http://www.luftlinie.org"          ' Zur Url surfen
      While Not .readyState = 4: DoEvents: Wend     ' Warten bis Seite geladen ist
          With .Document
              Set oNode = .getElementById("start")
              If Not oNode Is Nothing Then
                 oNode.Value = tDist.Start
                 Set oNode = .getElementById("end")
                 On Error Resume Next
                 If Not oNode Is Nothing Then
                    oNode.Value = tDist.Ziel
                    Set oNode = .getElementById("calcDistance")
                    If Not oNode Is Nothing Then oNode.Click
                    Do
                       Sleep 100
                       Set oNode = Nothing
                       Set oNode = .getElementById("strck")
                       If Not oNode Is Nothing Then
                          If Not oNode.outerText Like "*--*" Then Exit Do
                       End If
                       DoEvents
                    Loop
                    tDist.LDist = .getElementsByClassName("value km")(0).outerText
                    tDist.FDist = .getElementById("strck").outerText
                    tDist.Start = tDist.Start & " " & .getElementsByClassName("regions")(0).outerText
                    tDist.Ziel = tDist.Ziel & " " & .getElementsByClassName("regions")(2).outerText
                 End If         ' End
              End If            ' Start
          End With
          .Quit                 ' IE schließen
      End With
End Sub

_________
viele Grüße
Karl-Heinz

Anzeige
AW: Luftlinie Berechnen
30.01.2021 21:16:48
Suysaler
Super danke dir Karl-Heinz :)
Ich habe es gerade ausprobiert und funktioniert soweit.
Nun meine Frage.. Gibt es eine möglichkeit die Daten von der Mappe abfragen zu lassen damit ich nicht jedesmal die Adresse einfügen muss?
Beispiel habe ich als Upload dabei
Der Start ist immer Zelle A und die Ziele in Zelle B
Kann man da einzeln die 'Zielspalten' ausfüllen lassen?
Hat da jemand eine Idee dazu?
Userbild
AW: Luftlinie Berechnen
30.01.2021 21:58:41
volti
Hallo,
hier zwei Möglichkeiten des Aufrufs:
Code:



[Cc][+][-]



Sub EntfernungErmitteln()
' Einzelentfernung für die aktuelle Zeile
  Dim tDist As DIST_STRUCT

  With tDist
      .Start = Cells(ActiveCell.Row, "A").Value
      .Ziel = Cells(ActiveCell.Row, "B").Value
      If .Start <> "" And .Ziel <> "" Then
         GetDistance tDist
         Cells(ActiveCell.Row, "C").Value = .LDist & " km"
      End If
  End With

End Sub

Sub EntfernungErmittelnViele()
' Liste ausfüllen
  Dim tDist As DIST_STRUCT, iZeile As Integer
  Dim WSh As Worksheet
  
  Set WSh = ActiveSheet

  For iZeile = 1 To WSh.Cells(Rows.Count, "A").End(xlUp).Row
     With tDist
        .Start = WSh.Cells(iZeile, "A").Value
        .Ziel = WSh.Cells(iZeile, "B").Value
        If .Start <> "" And .Ziel <> "" Then
           GetDistance tDist
           WSh.Cells(iZeile, "C").Value = .LDist & " km"
        End If
     End With
  Next iZeile
  
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Anzeige
AW: Luftlinie Berechnen
30.01.2021 21:06:52
Wolfgang
Hallo,
vor Jahren wollte ich auch so eine Tabelle erstellen und habe im Internet nach Hilfe gesucht.
Leider wurde ich mit der damaligen Beispieldatei etwas "überfordert" mit VBA und habe das Ganze in die "unterste Schublade gelegt".
Ich sende mal hier die Beispieldatei, vielleicht gibt es jemanden der das perfektionieren kann.
https://www.herber.de/bbs/user/143463.xls
Grüße
Wolfgang
AW: Luftlinie Berechnen
31.01.2021 00:09:45
volti
Hallo Wolfgang,
wenn das mit Luftlinie.org ausgefüllt werden soll, kannst Du dieses Makro mal ausprobieren.
Dauert allerdings bei den vielen Orten 'ne Weile.
Du kannst Luftlinie oder Fahrstrecke ausfüllen lassen.
Das dort enthaltene Google.Maps habe ich nicht weiter verfolgt.
Code:

Option Explicit
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Sub Entfernung()
   'es werden immer nur die leeren Zellen abgefragt
  Dim oIE As Object, oNode As Object, WSh As Worksheet
  Dim i As Integer, j As Long, Items As String
    
  Set WSh = Tabelle1
    
  Set oIE = CreateObject("InternetExplorer.Application")
  oIE.Visible = False
      
  For i = 2 To WSh.UsedRange.Columns.Count
    
    If WSh.Cells(1, i).Value = "" Then Exit For
    For j = 2 To Tabelle1.UsedRange.Rows.Count
      If WSh.Cells(j, 1).Value = "" Then Exit For
      If WSh.Cells(j, i).Value = "" Then
         If WSh.Cells(1, i).Value <> Tabelle1.Cells(j, 1).Value Then
           Items = "/" & WSh.Cells(1, i).Value & "/" & WSh.Cells(j, 1).Value
           oIE.navigate "http://www.luftlinie.org" & Items  ' Zur Url surfen
           While Not oIE.readyState = 4: DoEvents: Wend     ' Warten bis Seite geladen ist
          
           With oIE.document
              Do
                 Sleep 50
                 Set oNode = Nothing
                 Set oNode = .getElementById("strck")
                 If Not oNode Is Nothing Then
                    If Not oNode.outerText Like "*--*" Then Exit Do
                 End If
                 DoEvents
              Loop
' Luftlinie
              WSh.Cells(j, i).Value = .getElementsByClassName("value km")(0).outerText
' Fahrstrecke
'             WSh.Cells(J, I).Value = .getElementById("strck").outerText
              WSh.Cells(i, j).Value = WSh.Cells(j, i).Value
           End With
         Else
           WSh.Cells(j, i).Value = 0
         End If
      End If
    Next j
  
  Next i
  
  oIE.Quit
  Set oIE = Nothing
  MsgBox "Fertig"
End Sub

_________
viele Grüße
Karl-Heinz

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige
Archiv - Verwandte Themen
Forumthread
Beiträge
6