haben nachstehendes Makro für ein Entfernungswerk in eine Excel 2010 Arbeitsmappe eingebaut. Anfänglich lief das Makro, erhalten nun aber ständig die Meldung.
Wenn ich die Datei mit Excel 2013 bearbeitet erhalte ich nicht die Fehlermeldung, ist aber keine Alternative weil die Arbeitsrechner alle Office 2010 haben.
Fehler 91
Objektbvariable oder With-Blockvariable nicht festgelegt.
Ich habe die Datei auf den Server geladen und hoffe das einer mir fehlen kann. https://www.herber.de/bbs/user/111077.xlsm
Nachstehende nochmals der Code:
Vielen Dank schon zum jetzigem Zeitpunkt für eure Hilfe.
Gruss
Dirk
Public Sub GoogleTest()
'Variablendeklarastionen
'Objekt - Late Binding
Dim objXML As Object 'fuer XML-"String"
Dim xmlDoc As Object
Dim xmlNod As Object
'Objekt - Early Binding
'Dim xmlDoc As New MSXML2.DOMDocument
'Dim xmlNod As MSXML2.IXMLDOMNode
'String
Dim strOAddr$, strDAddr
'Integer
Dim iCnt1%, iCnt2%
'Long
Dim lCnt&
On Error GoTo errorhandler
'Flackern aus
Application.ScreenUpdating = False
'XML-Objecte instanzieren
Set objXML = CreateObject("Msxml2.XMLHTTP")
Set xmlDoc = CreateObject("MSXML2.DOMDocument")
'Wenn Instanzierung nicht nichts gebracht hat, dann
If Not objXML Is Nothing Then
'Zeile und Spalte fuer OriginAddress
iCnt1 = 4: iCnt2 = 3
'Schleife ueber alle OriginAddress anhand Eintraegen in Zeile 4
'Tue solange Zellinhalt nicht leer
Do While Cells(4, iCnt2) ""
'Wenn Eintrag Berechnen in Zeile 7 = "JA", dann
If UCase(Cells(7, iCnt2)) = "JA" Then
'OriginAddress ermitteln
'Hinweise:
'Keine deutschen "Sonderbuchstaben" verwendbar
'PLZ auch 4stellig moeglich
'Zeile 4 = Straße, Zeile 5 = PLZ, Zeile 6 = Ort
strOAddr = ReplaceGermans(Cells(iCnt1, iCnt2)) & "," & Format(Cells(iCnt1 + 1, iCnt2), "0# _
_
_
###") & "," & ReplaceGermans(Cells(iCnt1 + 2, iCnt2))
'Schleife ueber alle DestinationAddress anhand Eintraegen in Spalte A
For lCnt = 11 To Cells(Rows.Count, 1).End(xlUp).Row
'DestinationAddress ermitteln
'Hinweise:
'Keine deutschen "Sonderbuchstaben" verwendbar
'PLZ nicht 4stellig moeglich!
'Spalte A = PLZ, Spalte B = Ort
strDAddr = Format(Cells(lCnt, 1), "0####") & "," & ReplaceGermans(Cells(lCnt, 2))
'Abfrage oeffnen
objXML.Open "POST", "http://maps.googleapis.com/maps/api/distancematrix/xml?origins=" & _
strOAddr & "&destinations=" & strDAddr & "&language=de-DE&sensor=false", False
'Abfrageheader
objXML.setRequestHeader "Content-Type", "content=text/html; charset=UTF-8"
'Abfrage senden
objXML.send
'Abfrageergebnis (Text) aufnehmen
xmlDoc.LoadXML objXML.responseText
'Zeit auslesen /Value=Sekunden /Text = Minuten mit Angabe "Minuten"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/duration/value")
'Zeit in Stundenzelle eintragen, Rueckgabewert / 86400
Cells(lCnt, iCnt2 + 1) = CDate(xmlNod.Text / 86400)
'Entfernung auslesen /Value=Meter /Text = Kilometer mit Angabe "km"
Set xmlNod = xmlDoc.SelectSingleNode("//row/element/distance/value")
'Entfernung in km zelle eintragen, Rueckgabewert / 1000
Cells(lCnt, iCnt2) = xmlNod.Text / 1000
'Ende Schleife ueber alle DestinationAddress anhand Eintraegen in Spalte A
Next
'Ende Wenn Eintrag Berechnen in Zeile 7 = "JA", dann
End If
'Spaltenzaehler hochsetzen
iCnt2 = iCnt2 + 2
'Ende Tue solange Zellinhalt nicht leer
Loop
'Ende Wenn Instanzierung nicht nichts gebracht hat, dann
End If
'Fehlerbehandlung / Programmende
errorhandler:
'Flackern ein
Application.ScreenUpdating = True
'Wenn Fehlernummer 0, dann Ausgabe Fehlermeldung
If Err.Number 0 Then MsgBox "Fehler: " & Err.Number & vbLf & Err.Description
'XML-Objecte zuruecksetzen
Set xmlNod = Nothing
Set xmlDoc = Nothing
Set objXML = Nothing
End Sub
Function ReplaceGermans(ByVal strText As String) As String
'Funktion ersetzt deutsche Umlaute
'Variablendeklaration
'Integer
Dim iCnt%
'Array
Dim arrRep
'Array mit Umlauten und Replacements definieren
arrRep = Array("Ö", "Oe", "ö", "oe", "Ä", "Ae", "ä", "ae", "Ü", "Ue", "ü", "ue", "ß", "ss")
'Schleife von 0 bis Ende vom Array, Schrittweite 2
For iCnt = 0 To UBound(arrRep) Step 2
'Umlaut mit Replacement ersetzen
strText = Replace(strText, arrRep(iCnt), arrRep(iCnt + 1))
'Ende Schleife von 0 bis Ende vom Array, Schrittweite 2
Next
'ReplaceGermans = strText
ReplaceGermans = strText
End Function