• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Import Point from xml code

sanju

Member
Dear sir,
Imports the Kml file as xml format but it only imposes only single point. Can it import all the points as shown in sheet2.
Thank you.

Code:
 Sub Import_Point()
Dim KmlFileLoc As String, text As String, textline As String
KmlFileLoc = Application.GetOpenFilename()
'Won't read a KML, so you gotta make it a text file
KmlTxtCopy = KmlFileLoc & ".txt"
FileCopy KmlFileLoc, KmlTxtCopy
Open KmlTxtCopy For Input As #1
'EOF stands for End of File
Do Until EOF(1)
Line Input #1, textline
text = text & textline
Loop
Close #1
posName = InStr(text, "<name> ")
posEndName = InStr(text, " </name>")
PName = Mid(text, posName + 6, posEndName - posName - 6)
posCoords = InStr(text, "coordinates") + 12
posEndCoords = InStr(text, "</coordinates")
CoordVals = Mid(text, posCoords, posEndCoords - posCoords)
Dim pwb As Worksheet
Set pwb = ActiveSheet
Dim l As Integer
l = 1
Do While InStr(CoordVals, ",") > 1
CommaPos = InStr(CoordVals, ",")
Longitude = Left(CoordVals, CommaPos - 1)
pwb.Cells(l + 2, 2).Value = Longitude
'Trim out that Longitude excluding the comma
CoordVals = Right(CoordVals, Len(CoordVals) - CommaPos)
'Do the Same for Latitude but in 2nd Column
CommaPos = InStr(CoordVals, ",")
Latitude = Left(CoordVals, CommaPos - 1)
pwb.Cells(l + 2, 1).Value = Latitude
CoordVals = Right(CoordVals, Len(CoordVals) - CommaPos - 1)
pwb.Cells(2, 1).Value = "Latitude"
pwb.Cells(2, 2).Value = "Longitude"
pwb.Cells(2, 3).Value = "Name"
pwb.Cells(l + 2, 3).Value = PName
l = l + 1
Loop
End Sub
 

Attachments

  • Required File.xlsm
    26.9 KB · Views: 3
  • Point.kml.txt
    98.3 KB · Views: 6
Why not simply open it as a TXT file
Excel will recognise it is an XML file and allow you to import it directly

upload_2018-2-15_16-18-59.png

You will have to do Text to Columns on Column J to extract the Lats and Longs to separate columns
 
like:
Code:
Sub Import_KML_File()

    Workbooks.OpenXML Filename:="C:\Users\Owner\Downloads\Point.kml", LoadOption:=xlXmlLoadImportToList
    Columns("K:K").Delete Shift:=xlToLeft
    Columns("J:J").TextToColumns _
        Destination:=Range("Table1[[#Headers],[ns1:coordinates]]"), _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=True, _
        Semicolon:=False, _
        Comma:=True, _
        Space:=False, _
        Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
End Sub
 
like:
Code:
Sub Import_KML_File()

    Workbooks.OpenXML Filename:="C:\Users\Owner\Downloads\Point.kml", LoadOption:=xlXmlLoadImportToList
    Columns("K:K").Delete Shift:=xlToLeft
    Columns("J:J").TextToColumns _
        Destination:=Range("Table1[[#Headers],[ns1:coordinates]]"), _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=True, _
        Semicolon:=False, _
        Comma:=True, _
        Space:=False, _
        Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
End Sub

Dear sir,
Thank you so much for the reply,
But I want to import only three values "latitude" "longitude" and "point name".
is that possible?
 
see revised code

Code:
Sub Import_KML_File()

    Workbooks.OpenXML Filename:="C:\Users\PC_1\Desktop\Point.kml", LoadOption:=xlXmlLoadImportToList
    Columns("K:K").Delete Shift:=xlToLeft
    Columns("J:J").TextToColumns _
        Destination:=Range("Table1[[#Headers],[ns1:coordinates]]"), _
        DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, _
        Tab:=True, _
        Semicolon:=False, _
        Comma:=True, _
        Space:=False, _
        Other:=False, _
        FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1)), _
        TrailingMinusNumbers:=True
    Columns("A:B").Delete Shift:=xlToLeft
    Columns("B:G").Delete Shift:=xlToLeft
    Range("Table1[[#Headers],[ns1:name3]]").Select
    ActiveCell.FormulaR1C1 = "ID"
    Range("Table1[[#Headers],[ns1:coordinates]]").Select
    ActiveCell.FormulaR1C1 = "Lat"
    Range("Table1[[#Headers],[Column1]]").Select
    ActiveCell.FormulaR1C1 = "Long"
    Range("Table1[[#Headers],[Column2]]").Select
    ActiveCell.FormulaR1C1 = "RL"
    Range("A1").Select
End Sub
 
Back
Top