Excel macro to KML using VBA Loop

Question

I am trying to write a VBA loop which will turn a list of addresses and their corresponding Lat Long coordinates in to a KML file for viewing in Google Earth.

I have managed to get the opening and closing KML tags in, but can't work out how to loop only the coordinates in to the coordinate tags, and have the addresses in their own tag. If anyone could lend a hand, I will be eternally in their debt! (Ultimately, I will want to have the following info in the KML File: Job Number, House Number + Street name (combined in KML Placemark tag, but from different Excel cells), City, Lat/Long. However, for my learning I currently have address and latlong.

A1: Addresses, B1: Lat, C1: Long

Current results:

"<?xml version=""1.0"" encoding=""UTF-8""?><kml xmlns=""http://earth.google.com/kml/2.2""><Document>"
"<coordinates>1892 Mccreary Road,49.950362,-97.0804002</coordinates>"
"<coordinates>38 Monarch Mews,49.948567,-97.0784119</coordinates>"
"<coordinates>3170 Vialoux Drive,49.9482365,-97.0775992</coordinates>"
"</Document></kml>"

Code:

Sub WriteTextFile()

Worksheets("Sheet1").Range("A1").Activate

Dim FilePath As String
Dim CellData As String
Dim LastCol As Long
Dim LastRow As Long
Dim CoordOpen As String
Dim CoordClose As String
Dim KMLCrap As String
Dim KMLCrapClose As String

Const HEADER As String = "<?xml version=""1.0"" encoding=""UTF-8""?><kml xmlns=""http://earth.google.com/kml/2.2"">" + ("<Document>")

LastCol = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column
LastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row

CellData = ""

FilePath = "C:\Users\TeamCK\Desktop\VBA To KML Org\Original Examples\Great Loop.txt"

Open FilePath For Output As #2

KMLCrap = ("<?xml version=""1.0"" encoding=""UTF-8""?>") + ("<kml xmlns=""http://earth.google.com/kml/2.2"">") + ("<Document>")

Write #2, KMLCrap

CoordOpen = "<coordinates>"
CoordClose = "</coordinates>"

    For I = 1 To LastRow
        For J = 1 To LastCol
            If J = LastCol Then
                CellData = CellData + Trim(ActiveCell(I, J).Value)
            Else
                CellData = CellData + Trim(ActiveCell(I, J).Value) + ","
            End If
        Next J
            Write #2, CoordOpen + CellData + CoordClose
            CellData = ""
    Next I

KMLCrapClose = ("</Document></kml>")
Write #2, KMLCrapClose

Close #2

MsgBox ("Done")

End Sub

Hornbydd · Accepted Answer · 2014-09-25 22:05:59Z

1

I would stop what you are doing and have a look at the KML specifications as what you appear to be generating albeit wrong does not conform to KML standards. Have a look at this tutorial and study the structure, you don't appear to be enclosing it in a placemarker tag? So even if you get your address sorted it would be invalid KML.

Personally if this was me doing it I would build the KML as XMLDOM object and then write that out as a KML file...

answered Sep 25, 2014 at 22:05

Hornbydd

45k5 gold badges43 silver badges84 bronze badges

Cheers for the comment - I took this on, on a whim and even advice is appreciated. Surely though, since you can program VBA to loop, and to print text, and to send to a text file, which you can relabel to KML which can be imported in to google earth... surely it can all be done in VBA? I know it is missing the Placemarker tag, I could barely get the Coordinates bit to work, and gave up before I got to that point!

Christography
– Christography

2014-09-26 01:13:59 +00:00
Commented Sep 26, 2014 at 1:13
What I am suggesting can all be done in VBA. I have done it in the past using VBA in ArcMap. I would try to use the XLMDOM route as it will help you in structuring the XML file. But do go through that tutorial first, it will save you hours of head banging!

Hornbydd
– Hornbydd

2014-09-26 09:59:33 +00:00
Commented Sep 26, 2014 at 9:59
Will do - cheers mate!

Christography
– Christography

2014-09-26 17:38:35 +00:00
Commented Sep 26, 2014 at 17:38

Add a comment |

mksugumaran · Accepted Answer · 2015-04-01 06:14:42Z

I published Excel to Google Earth KML converter using VBA Macro in the following link with explanatory notes also. [http://mksugumaran.blogspot.com/2013/09/excel-to-google-earth-kml.html][1] http://mksugumaran.blogspot.com/2013/09/excel-to-google-earth-kml.html

The Actual Macro code is given below:

Sub EXPORTKMLMARK()
Dim DATA(10000, 25)
sh2 = ActiveWindow.RangeSelection.Address(True, True, xlR1C1, False, False)
BNAME = InputBox("Enter file name:")
NAMC = CInt(InputBox("ENTER COLUMN NO TO MARK IN MAP"))
FNAME = BNAME & ".KML"
N1 = InStr(1, sh2, ":", 1)
If N1 = 0 Then
N2 = InStr(1, sh2, "C", 1)
RN1 = CInt(Mid(sh2, 2, N2 - 2))
CN1 = CInt(Mid(sh2, N2 + 1))
RN2 = RN1
CN2 = CN1
End If
If N1 > 0 Then
N2 = InStr(1, sh2, "C", 1)
RN1 = CInt(Mid(sh2, 2, N2 - 2))
CN1 = CInt(Mid(sh2, N2 + 1, N1 - N2 - 1))
N3 = InStr(N1 + 1, sh2, "C", 1)
RN2 = CInt(Mid(sh2, N1 + 2, N3 - N1 - 2))
CN2 = CInt(Mid(sh2, N3 + 1))
End If
NR = RN2 - RN1
NC = CN2 - CN1
Open FNAME For Output As #1
Print #1, "<?xml version='1.0' encoding='UTF-8'?>"
Print #1, "<kml xmlns='http://www.opengis.net/kml/2.2'"
Print #1, "xmlns:gx='http://www.google.com/kml/ext/2.2'"
Print #1, "xmlns:kml='http://www.opengis.net/kml/2.2'"
Print #1, "xmlns:atom='http://www.w3.org/2005/Atom'>"
Print #1, "<Document>"
Print #1, "<name>"
Print #1, FNAME
Print #1, "</name>"
Print #1, "<Style id='sn_ylw-pushpin'>"
Print #1, "<IconStyle>"
Print #1, "<scale>0.5</scale>"
Print #1, "<Icon>"
Print #1, "<href>http://maps.google.com/mapfiles/kml/pushpin/ylw-pushpin.png</href>"
Print #1, "</Icon>"
Print #1, "<hotSpot x='20' y='2' xunits='pixels' yunits='pixels'/>"
Print #1, "</IconStyle>"
Print #1, "</Style>"
Print #1, "<Style id='sh_ylw-pushpin'>"
Print #1, "<IconStyle>"
Print #1, "<scale>0.590909</scale>"
Print #1, "<Icon>"
Print #1, "<href>http://maps.google.com/mapfiles/kml/pushpin/ylw-pushpin.png</href>"
Print #1, "</Icon>"
Print #1, "<hotSpot x='20' y='2' xunits='pixels' yunits='pixels'/>"
Print #1, "</IconStyle>"
Print #1, "</Style>"
Print #1, "<StyleMap id='msn_ylw-pushpin'>"
Print #1, "<Pair>"
Print #1, "<key>normal</key>"
Print #1, "<styleUrl>#sn_ylw-pushpin</styleUrl>"
Print #1, "</Pair>"
Print #1, "<Pair>"
Print #1, "<key>highlight</key>"
Print #1, "<styleUrl>#sh_ylw-pushpin</styleUrl>"
Print #1, "</Pair>"
Print #1, "</StyleMap>"
'DQ = UCase(InputBox("YOU WANT QUERY LINK? <Y/N>"))
'DA = UCase(InputBox("YOU WANT DATA ADD LINK? <Y/N>"))
For I = 0 To NR
For J = 0 To NC
DATA(I, J) = Cells(RN1 + I, CN1 + J).Value
Next J
Next I
For I = 1 To NR
Print #1, "<Placemark>"
        Print #1, "<name>" & DATA(I, NAMC - 1) & "</name>"
        Print #1, "<description>"
        Print #1, "<![CDATA[<table style=border-collapse:collapse; border=1>"

For J = 0 To NC
        Print #1, "<TR><TD>"
        Print #1, DATA(0, J)
        Print #1, "</TD><TD>"
        Print #1, DATA(I, J)
        Print #1, "</TD></TR>"
        Next J
        Print #1, "</TABLE>]]>"
        Print #1, "</description>"
        Print #1, "<styleUrl>#msn_ylw-pushpin</styleUrl>"
        Print #1, "<Point>"
        Print #1, "<coordinates>"
        YC1 = DATA(I, NC - 1)
        XC1 = DATA(I, NC)
        ZC1 = 0
        Print #1, Format(XC1, "##.00000000000000") & "," & Format(YC1, "##.00000000000000") & "," & Format(ZC1)
        Print #1, "</coordinates>"
        Print #1, "</Point>"
        Print #1, "</Placemark>"
        Next I
        Print #1, "</Document>"
        Print #1, "</kml>"

Close #1
End Sub

Stack Exchange Network

Excel macro to KML using VBA Loop

2 Answers 2

Your Answer

Hot Network Questions

Excel macro to KML using VBA Loop

2 Answers 2

Your Answer

Sign up or log in

Post as a guest

Related

Hot Network Questions