7 Dicas para Aprimorar o Uso de Tabelas Dinâmicas – Excel
29 de maio de 2011
Função para retornar o nome das planilhas
Função para retornar o nome das planilhas
1 de junho de 2011

Objetivo: Importar dados de uma consulta XML no Excel.


//

Lomadee, uma nova espécie na web. A maior plataforma de afiliados da América Latina.

 


Para criar uma consulta XML clique em Dados -> Da Web e digite o endereço da consulta, como por exemplo: https://maps.google.com/maps/api/geocode/xml?address=Rui+Barbosa+1300,Joinville,SC&sensor=false.

Abaixo o código VBA que cria uma consulta  XML para o Google Maps, trazendo informações como o endereço completo, latitude, longitude, etc.

O botão da planilha está associado a este código VBA, que exclui a consulta anterior e cria uma nova consulta com os dados fornecidos nas células de B1 á B5, a célula B6 relacionada ao CEP é preenchida automaticamente.

Sub lsCriaConexaoXML()
    Dim lDados As String

    Dim iTotalLinhas As Integer

    Selection.End(xlDown).Select
    iTotalLinhas = Cells(Rows.Count, 1).End(xlUp).Row

    If ActiveWorkbook.Connections.Count > 0 Then
        ActiveWorkbook.Connections(1).Delete
    End If

    lDados = Range("B1").Value & "+" & Range("B2").Value & "," & Range("B3").Value & "," & Range("B4").Value & "," & Range("B5").Value

    Rows("9:30").Select
    Selection.Delete Shift:=xlUp

    ActiveWorkbook.XmlImport URL:= _
        "https://maps.google.com/maps/api/geocode/xml?address=" & lDados & "&sensor=false" _
        , ImportMap:=Nothing, Overwrite:=True, Destination:=Range("$A$9")

    Range("B6").Value = Range("D" & iTotalLinhas).Value

End Sub

GUT PPT

Abraço

Marcos Rieper

//

Lomadee, uma nova espécie na web. A maior plataforma de afiliados da América Latina.

 

8 Comments

  1. Felipe disse:

    Gostaria de saber como montar uma planilha que com apenas o cep ela preenche rua, bairro, cidade e etc…

  2. Diego Pedro disse:

    Ola Amigo estou tentando executar essa macro, mas esta apresentado erro em tempo de execução, vc sabe o que pode ser?

  3. clayton disse:

    Olá Marcos,

    Esta planilha é ótima, mas quando altero o endereço ela aparece “INVALID_REQUEST”

  4. Adriano Costa disse:

    Para a macro funcionar corretamente o endereço procurado deve vir sem acentos. Se tiver acento a macro converte para unicode, complicando ainda mais a consulta, então é melhor manter a busca toda sem acentos.

  5. audeser disse:

    Saudos Marcos, despois de romper moito a cabeza con esta macro, (supoño que os problemas que preguntan mais arriba é por esta mesmo tema), deime conta que a macro erraba de aparecer caracteres especiais como os do formato “Latin1” (esto é: Á, É,…, Ñ, ñ,…), porque o XML require que a codificación veña en UFT-8.

    A tal, correxin un tanto a macro, para acabar de limpar outras cousas que non estaban rematadas, que deseguido se adxunta.

    Parabens, meu.

    ‘——————————————————
    Option Explicit

    Private Const adTypeBinary As Long = 1
    Private Const adTypeText As Long = 2
    Private Const adModeReadWrite As Long = 3

    Public Function URLEncode(ByVal StringToEncode As String) As String
    Dim i As Integer
    Dim iAsc As Long
    Dim sTemp As String
    Dim ByteArrayToEncode() As Byte

    If StringToEncode vbNullString Then
    ByteArrayToEncode = ADO_EncodeUTF8(StringToEncode)

    For i = 0 To UBound(ByteArrayToEncode)
    iAsc = ByteArrayToEncode(i)
    Select Case iAsc
    Case 32 ‘space
    sTemp = “+”
    Case 48 To 57, 65 To 90, 97 To 122
    sTemp = Chr(ByteArrayToEncode(i))
    Case Else
    ‘Debug.Print iAsc
    sTemp = “%” & Hex(iAsc)
    End Select
    URLEncode = URLEncode & sTemp
    Next
    End If
    End Function

    Public Function ADO_EncodeUTF8(ByVal strUTF16 As String) As Byte()
    ‘Purpose: UTF16 to UTF8 using ADO
    Dim objStream As Object

    Set objStream = CreateObject(“ADODB.Stream”)
    With objStream
    .Charset = “utf-8”
    .Mode = adModeReadWrite
    .Type = adTypeText
    .Open
    .writetext strUTF16
    .Flush
    .Position = 0
    .Type = adTypeBinary
    .Read 3 ‘ skip BOM (2 first bytes)
    ADO_EncodeUTF8 = .Read()
    .Close
    End With
    Set objStream = Nothing
    End Function

    Public Sub sXML_Get()
    Dim strData As String
    Dim strURL As String
    Dim lgRetVal As Long
    Dim xlRange As Excel.Range
    Dim oXML_Map As XmlMap
    Dim strStreet As String
    Dim strNumber As String
    Dim strDistrict As String
    Dim strPostalCode As String
    Dim strCity As String
    Dim strCountry As String

    ‘Delete previously assigned connections
    ‘Application.CommandBars(“XML Source”).Visible = True
    Do While ActiveWorkbook.Connections.Count > 0
    ActiveWorkbook.Connections(1).Delete
    Loop

    Do While ActiveWorkbook.XmlMaps.Count > 0
    ActiveWorkbook.XmlMaps(1).Delete
    Loop
    ‘Application.CommandBars(“XML Source”).Visible = False

    ‘Range(“A1”).Value = “Street”
    ‘Range(“A2”).Value = “Number”
    ‘Range(“A3”).Value = “District”
    ‘Range(“A4”).Value = “Locality/City”
    ‘Range(“A5”).Value = “Postal code”
    ‘Range(“A6”).Value = “Country”

    strStreet = VBA.Replace(URLEncode(Range(“B1″).Value), ” “, “+”)
    strNumber = VBA.Replace(URLEncode(Range(“B2″).Value), ” “, “+”)
    strDistrict = VBA.Replace(URLEncode(Range(“B3″).Value), ” “, “+”)
    strCity = VBA.Replace(URLEncode(Range(“B3″).Value), ” “, “+”)
    strPostalCode = VBA.Replace(URLEncode(Range(“B3″).Value), ” “, “+”)
    strCountry = VBA.Replace(URLEncode(Range(“B6″).Value), ” “, “+”)

    strData = strStreet & “+” & _
    VBA.IIf(strNumber = vbNullString, “”, strNumber & “,”) & _
    VBA.IIf(strDistrict = vbNullString, “”, strDistrict& & “,”) & _
    VBA.IIf(strCity = vbNullString, “”, strCity & “,”) & _
    VBA.IIf(strPostalCode = vbNullString, “”, strPostalCode & “,”) & _
    strCountry ‘Actually, country is not needed
    Set xlRange = Range(“$A$9”)
    With ActiveWorkbook
    strURL = “https://maps.google.com/maps/api/geocode/xml?address=” & _
    strData & _
    “&sensor=false”
    Debug.Print strURL

    ‘.XmlMaps(“setFilterRespMap”).Import strURL
    ‘Set oXML_Map = .XmlMaps(“LogonResponseMap”)
    ‘lgRetVal = ‘To get response data from XML Import
    .XmlImport _
    url:=strURL, _
    ImportMap:=Nothing, _
    Overwrite:=True, _
    Destination:=xlRange
    End With
    Set xlRange = Nothing

    End Sub

Deixe uma resposta

O seu endereço de e-mail não será publicado. Campos obrigatórios são marcados com *

Esse site utiliza o Akismet para reduzir spam. Aprenda como seus dados de comentários são processados.

Inscreva-se no nosso canal do Youtube!


Junte-se ao nosso canal do Youtube. Começamos em abril de 2016, mas já temos mais de 06:00 h de treinamentos gratuitos e este número irá aumentar. Vídeos novos todos os sábados.