Sub Crear_kml()
Dim encabezado1 As String
Dim encabezado2 As String
Dim placemark As String
Dim nombre As String
Dim abrir As String
Dim LookAt1 As String
Dim LookAt2 As String
Dim coordenadas() As Variant
Dim puntos() As Variant
Dim description() As Variant
encabezado1 = "<?xml version=""1.0"" encoding=""UTF-8""?>"
encabezado2 = "<kml xmlns=""http://www.opengis.net/kml/2.2"">"
nombre = "<name>"
On Error Resume Next
Sheets("Codigo").Activate
If Err.Number <> 0 Then
Sheets.Add before:=Sheets(1)
ActiveSheet.Name = "Codigo"
Sheets("Codigo").Activate
Err.Clear
On Error GoTo 0
Else
On Error GoTo 0
ActiveSheet.Name = "Codigo"
ActiveSheet.Cells.Select
Selection.ClearContents
End If
Sheets("coordenadas").Activate
ult = Cells(Rows.Count, 1).End(xlUp).Row 'Obtiene la cantidad de celdas que tienen información
ReDim coordenadas(ult, 2)
ReDim puntos(ult)
ReDim description(ult)
For i = 1 To ult
For j = 1 To 2
coordenadas(i, j) = Cells(i + 1, j + 1)
Next j
puntos(i) = Cells(i + 1, 1)
description(i) = Cells(i + 1, 5)
Next i
Sheets("Codigo").Activate
ActiveSheet.Cells(1, 1) = encabezado1
ActiveSheet.Cells(2, 1) = encabezado2
ActiveSheet.Cells(3, 1) = "<Document>"
ActiveSheet.Cells(4, 1) = vbTab & "<Folder>"
ActiveSheet.Cells(5, 2) = vbTab & "<name>PUNTOS</name>"
ActiveSheet.Cells(6, 2) = vbTab & "<open>1</open>"
ActiveSheet.Cells(7, 2) = vbTab & "<LookAt>"
ActiveSheet.Cells(8, 3) = vbTab & "<longitude>" & coordenadas(1, 2) & "</longitude>" ' Aqui debe estar el Norte
ActiveSheet.Cells(9, 3) = vbTab & "<latitude>" & coordenadas(1, 1) & "</latitude>" ' Aqui debe estar el Sur
'ActiveSheet.Cells(10, 3) = vbTab & "<latitude>" & coordenadas(1, 3) & "</latitude>" ' Aqui debe estar la ZONA aun no se como arreglar esta fila
ActiveSheet.Cells(11, 2) = vbTab & "</LookAt>"
For i = 1 To ult - 1
j = 7 * (i - 1)
ActiveSheet.Cells(j + 12, 2) = vbTab & "<Placemark>"
ActiveSheet.Cells(j + 13, 3) = vbTab & "<name>" & puntos(i) & "</name>"
ActiveSheet.Cells(j + 14, 3) = vbTab & "<description>" & description(i) & "</description>"
ActiveSheet.Cells(j + 15, 3) = vbTab & "<Point>"
ActiveSheet.Cells(j + 16, 4) = vbTab & " <coordinates>" & coordenadas(i, 2) & "," & coordenadas(i, 1) & ",0</coordinates>" ' Aqui anida todo norte,este,zona.
ActiveSheet.Cells(j + 17, 3) = vbTab & "</Point>"
ActiveSheet.Cells(j + 18, 2) = vbTab & "</Placemark>"
Next i
ActiveSheet.Cells(j + 19, 1) = vbTab & "</Folder>"
ActiveSheet.Cells(j + 20, 1) = "</Document>"
ActiveSheet.Cells(j + 21, 1) = "</kml>"
Call EXPORTAR_TXT_CARACTERES
End Sub
Sub EXPORTAR_TXT_CARACTERES()
Dim i As Double
'Creamos automáticamente un .txt en blanco que llamamos EJEMPLO
'el archivo se creará en la misma unidad que tenemos el Excel.
Archivo_txt = "C:\Users\LENOVO\Desktop\Prueba2.kml" 'Prueba2.txt" para el codigo
'si queremos cambiar su ubicación basta con poner Archivo_txt = "E:\EJEMPLO.txt"
Open Archivo_txt For Output As #1
With ActiveWorkbook.Sheets(1)
fin = .Cells(Rows.Count, 1).End(xlUp).Row
'realizamos bucle para pasar los datos al txt
For i = 1 To fin
'ejemplo de txt delimitado por caracteres Tab
Print #1, .Cells(i, 1) & vbTab & .Cells(i, 2) & vbTab & .Cells(i, 3) & vbTab & .Cells(i, 4) '.Range(i & ":" & i)
Next i
Close
End With
Sheets(1).Delete
End Sub
Aquí el código