• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Km ölçer problem hakkında ;

Katılım
6 Kasım 2016
Mesajlar
16
Excel Vers. ve Dili
2010 professional plus
Aşağıda bulunan kodu uzun zamandır kullanıyorum.
mantığı ,
1. sütuna paris 2. sütuna istanbul yazdığımızda 3. sütun a da kodu yapıştırdığımızda aralarındaki km yi vermekte. ilgili kodu çok fazla kullanıdığımızda bir şekilde kilitleniyor. İnterneti kapatıp açmadan da bir daha km vermiyor. bu konuda bana yardımcı olabilirmisin.
Aynı anda 1100 satıra birden yapıştırıyorum.


Kod:
Dim guzergah, konumu

Sub Menu()
sonsatir = Cells(Rows.Count, "A").End(3).Row
Range("Z5:Z100000").ClearContents
For i = 2 To sonsatir
  guzergah = turkce_harf_olmasin(Cells(i, 20).Value)
  konumu = turkce_harf_olmasin(Cells(i, 25).Value)
  Cells(i, 26).Value = mesafegetir(guzergah, konumu)
Next i
End Sub


Function mesafegetir(Origin, Destination) As Double
' Requires a reference to Microsoft XML, v6.0
' Draws on the stackoverflow answer at bit.ly/parseXML
Dim myRequest As XMLHTTP60
Dim myDomDoc As DOMDocument60
Dim distanceNode As IXMLDOMNode
    mesafegetir = 0
    ' Check and clean inputs
    On Error GoTo exitRoute
    'Origin = WorksheetFunction.EncodeURL(Origin)
    'Destination = WorksheetFunction.EncodeURL(Destination)
    ' Read the XML data from the Google Maps API
    Set myRequest = New XMLHTTP60
    urlsi = "http://maps.googleapis.com/maps/api/directions/xml?origin=" _
        & Origin & "&destination=" & Destination & "&sensor=false"
    myRequest.Open "GET", urlsi, False
    myRequest.send
    ' Make the XML readable usign XPath
    Set myDomDoc = New DOMDocument60
    myDomDoc.LoadXML myRequest.responseText
    ' Get the distance node value
    Set distanceNode = myDomDoc.SelectSingleNode("//leg/distance/value")
    If Not distanceNode Is Nothing Then mesafegetir = distanceNode.Text / 1000
exitRoute:
    ' Tidy up
    Set distanceNode = Nothing
    Set myDomDoc = Nothing
    Set myRequest = Nothing
End Function

Public Function turkce_harf_olmasin(cumle)
gecici = ""
For i = 1 To Len(cumle)
          h = Mid(cumle, i, 1)
          Select Case h
            Case "ğ": gecici = gecici + "g"
            Case "Ğ": gecici = gecici + "G"
            Case "ü": gecici = gecici + "u"
            Case "Ü": gecici = gecici + "U"
            Case "ş": gecici = gecici + "s"
            Case "Ş": gecici = gecici + "S"
            Case "ç": gecici = gecici + "c"
            Case "Ç": gecici = gecici + "C"
            Case "ö": gecici = gecici + "o"
            Case "Ö": gecici = gecici + "O"
            Case "İ": gecici = gecici + "I"
            Case "ı": gecici = gecici + "i"
            Case "á": gecici = gecici + "a"
            Case "è": gecici = gecici + "e"
            Case "ä": gecici = gecici + "a"
            Case "ß": gecici = gecici + "b"
            Case Else: gecici = gecici + h
            End Select
Next i
turkce_harf_olmasin = gecici
End Function
[/QUOTE]
 
Geri
Üst