Import Point from xml code

[sanju]

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.

 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

 

[Hui]

Why not simply open it as a TXT file
Excel will recognise it is an XML file and allow you to import it directly



You will have to do Text to Columns on Column J to extract the Lats and Longs to separate columns

 

[Hui]

like:

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

 

[sanju]

like:

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?

 

[Hui]

see revised 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

 

[sanju]

Yes, the code is working very well at this time thanks a lot.