Giúp em sửa lỗi sai vòng lặp khi tạo file kml cho Google Map

quyenpv · 8/9/22

Em chào anh chị!
Em có 1 đoạn code để tạo ra file kml dùng cho Google Map. Em muốn tạo thư mục cho lớp huyện sau đó đến lớp xã và cuối cùng là lớp cho các địa điểm.
Dữ liệu ban đầu

Thường tạo bằng tay thì nó sẽ như thế này

Code của em sưu tầm và chỉnh sửa đang bị sai vòng lặp dẫn đến khi chạy

Code

Mã:

Sub Create_KML()

    ' Dim cLimit As Range
    ' Dim dLimit As Range
    Dim SiteID(), SiteName(), Group_Tinh(), Group_Huyen(), Colour(), Data0(), Data1(), Data2(), Data3(), Data4(), Data5(), StrLat(), StrLon() As String
    Dim Lat(), Lon() As Single
    Dim errFlag     As Boolean


    'Find the last cell in the x y columns
    cLimit = Range("C6").End(xlDown).Row
    dLimit = Range("D6").End(xlDown).Row
    rlimit = Range("A5").End(xlToRight).Column

    'Test for data completeness
    If cLimit <> dLimit Then
        MsgBox "Error: Number of Lat & Long coordinates do not match. Please correct."
        Exit Sub
    End If

    'Sort for the kml group
    Range(Cells(6, 1), Cells(dLimit, rlimit)).Select
    Selection.Sort key1:=Range("E6"), _
            order1:=xlAscending, Header:=xlNo

    aSize = cLimit - 5
    ReDim StrLat(aSize), StrLon(aSize), SiteID(aSize), SiteName(aSize), Group_Tinh(aSize), Group_Huyen(aSize), Colour(aSize), Data0(aSize), Data1(aSize), Data2(aSize), Data3(aSize), Data4(aSize), Data5(aSize)
    ReDim Lat(aSize), Lon(aSize)

    Data0(0) = Cells(5, 7).Value
    Data1(0) = Cells(5, 8).Value
    Data2(0) = Cells(5, 9).Value
    Data3(0) = Cells(5, 10).Value
    Data4(0) = Cells(5, 11).Value
    Data5(0) = Cells(5, 12).Value

    Range("A5").Select

    For rCount = 1 To cLimit - 5
        rPosition = rCount + 5
        SiteID(rCount) = Cells(rPosition, 1).Value
        SiteName(rCount) = Cells(rPosition, 2).Value
        Group_Tinh(rCount) = Cells(rPosition, 5).Value
        Group_Huyen(rCount) = Cells(rPosition, 6).Value
        Colour(rCount) = Cells(rPosition, 7).Value
        Data0(rCount) = Cells(rPosition, 8).Value
        Data1(rCount) = Cells(rPosition, 9).Value
        Data2(rCount) = Cells(rPosition, 10).Value
        Data3(rCount) = Cells(rPosition, 11).Value
        Data4(rCount) = Cells(rPosition, 12).Value
        Data5(rCount) = Cells(rPosition, 13).Value
        Lat(rCount) = Cells(rPosition, 3).Value
        Lon(rCount) = Cells(rPosition, 4).Value

    Next rCount


    'MsgBox Data0(0) & Data1(0) & Data2(0) & Data3(0)


    'Fail the conversion if the Lat/Long values are out of range
    errFlag = False
    For rCount = 1 To cLimit - 5
        If Lat(rCount) > 90 Then errFlag = True
        If Lat(rCount) < -90 Then errFlag = True
        If Lon(rCount) > 180 Then errFlag = True
        If Lon(rCount) < -180 Then errFlag = True
        If errFlag = True Then
            MsgBox "Coordinates are out of range"
            Exit Sub
        End If
    Next rCount

    ' Fix regional comma/decimal point
    For rCount = 1 To cLimit - 5
        If InStr(1, CStr(Lat(rCount)), ",") > 0 Then
            tmp = CStr(Lat(rCount))
            StrLat(rCount) = Replace(tmp, ",", ".")
        Else
            StrLat(rCount) = CStr(Lat(rCount))
        End If
        If InStr(1, CStr(Lon(rCount)), ",") > 0 Then
            tmp = CStr(Lon(rCount))
            StrLon(rCount) = Replace(tmp, ",", ".")
        Else
            StrLon(rCount) = CStr(Lon(rCount))
        End If
    Next rCount




    'Get FileName
    tName = "KML_Export_" & Format(Date, "yyyymmdd")

    fName = Application.GetSaveAsFilename(FileFilter:= _
            "KML Files (*.kml), *.kml", Title:="KML File Export", _
            InitialFileName:=tName)
    If fName = False Then Exit Sub

    'Count the number of folders to create
    gNum = 0
    gName = ""
    For rCount = 1 To cLimit - 5
        If Group_Tinh(rCount) <> gName Then
            gNum = fNum + 1
            gName = Group_Tinh(rCount)
        End If
    Next rCount

    hNum = 0
    hName = ""
    For i = 1 To cLimit - 5
        If Group_Huyen(i) <> hName Then
            hNum = fhNum + 1
            hName = Group_Huyen(i)
        End If
    Next i

    'MsgBox hName
    'Open & populate output file
    Open fName For Output As #1


    Call writeKmlInitial(GetFilenameFromPath(fName), 1)
    '
    'Open kml Group_Tinh/folder
    If gNum > 0 Then
        If Group_Tinh(1) = "" Then
            gName2 = "Undefined"
        Else
            gName2 = Group_Tinh(1)
        End If
        Print #1, "    <Folder>"
        Print #1, "        <name>" & gName2 & "</name>"
        Print #1, "        <open>1</open>"
        Print #1, "        <gx:balloonVisibility>1</gx:balloonVisibility>"
    End If


    'Populate the points
    gName = Group_Tinh(1)
    For rCount = 1 To cLimit - 5
        If gNum > 0 Then
            If Group_Tinh(rCount) <> gName Then
                gName = Group_Tinh(rCount)
                If gName = "" Then
                    gName2 = "Undefined"
                Else
                    gName2 = gName
                End If
                Print #1, "    </Folder>"
                Print #1, "    <Folder>"
                Print #1, "        <name>" & gName2 & "</name>"
                Print #1, "        <open>1</open>"
                Print #1, "        <gx:balloonVisibility>1</gx:balloonVisibility>"
            End If
        End If


        'Open kml Group_Tinh/folder
        If hNum > 0 Then
            If Group_Huyen(1) = "" Then
                hName2 = "Undefined"
            Else
                hName2 = Group_Huyen(1)
            End If
            Print #1, "    <Folder>"
            Print #1, "        <name>" & hName2 & "</name>"
            Print #1, "        <open>1</open>"
            Print #1, "        <gx:balloonVisibility>1</gx:balloonVisibility>"
        End If




        'Populate the points
        hName = Group_Huyen(1)
        For i = 1 To cLimit - 5
            If hNum > 0 Then
                If Group_Huyen(i) <> hName Then
                    hName = Group_Huyen(i)
                    If hName = "" Then
                        hName2 = "Undefined"
                    Else
                        hName2 = hName
                    End If
                    Print #1, "    </Folder>"
                    Print #1, "    <Folder>"
                    Print #1, "        <name>" & hName2 & "</name>"
                    Print #1, "        <open>1</open>"
                    Print #1, "        <gx:balloonVisibility>1</gx:balloonVisibility>"
                End If
            End If

            Print #1, "        <Placemark>"
            Print #1, "            <name>" & SiteID(i) & "</name>"

            Print #1, "            <LookAt>"
            Print #1, "                <longitude>" & StrLon(i) & "</longitude>"
            Print #1, "                <latitude>" & StrLat(i) & "</latitude>"
            Print #1, "                <altitude>0</altitude>"
            Print #1, "                <heading>-1.539914092246387e-008</heading>"
            Print #1, "                <tilt>0</tilt>"
            Print #1, "                <range>640383.0131348133</range>"
            Print #1, "                <gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>"
            Print #1, "            </LookAt>"


            Print #1, "            <Point>"
            Print #1, "                <gx:drawOrder>1</gx:drawOrder>"
            Print #1, "                <coordinates>" & StrLon(i) & "," & StrLat(i) & ",0</coordinates>"
            Print #1, "            </Point>"
            Print #1, "        </Placemark>"

        Next i


        'Finish off the folder/group
        If hNum > 0 Then
            Print #1, "        </Folder>"
        End If


    Next rCount
    'Finish off the folder/group
    If gNum > 0 Then
        Print #1, "        </Folder>"
    End If

    'Finish off the kml document
    Print #1, "</Document>"
    Print #1, "</kml>"
    Close #1

    MsgBox "Conversion Complete, see: " & fName

End Sub

batman1 · 9/9/22

Bạn phải đọc thật kỹ những lưu ý sau đây.

1. Tôi thú nhận không cần tra tấn là tôi chưa bao giờ làm việc với tập tin KML. Vì thế tôi không biết cấu trúc của KML thế nào. Vì lẽ đó tôi không xem code trong Module11, cụ thể là Sub writeKmlInitial. Tôi không quan tâm nó có ghi đúng cấu trúc của KML hay không. Cũng vì lẽ này những code trong Module1 ghi từng dòng vào tập tin KML (dùng Print) tôi cũng chấp nhận là cấu trúc nó phải thế. Tuy nhiên xét về mặt lôgíc thì code Sub Create_KML có vấn đề. Cái này nó không liên quan gì tới KML, nó thuần túy là lôgíc lập trình. Và tôi chỉnh sửa sai sót của bạn về mặt lôgíc. Tôi nhắc lại: Tôi không biết cấu trúc KML thế nào. Tôi coi như là bạn biết cấu trúc đó.
Code tôi chỉnh sửa ở dưới.

2. Bạn dùng Print nên không ghi được unicode - tiếng Việt.

3. Các việc bạn cần làm.
Tôi mới chỉ chỉnh về mặt lôgíc. Bạn nên dùng FileSystemObject để ghi thay cho Print. Như thế bạn sẽ có tiếng Việt.
Bạn nên viết lại code. Dữ liệu có thể đọc vào mảng trong một nốt nhạc chứ không như code của bạn đọc từng ô từ sheet vào mảng. Mà nếu dùng thì nếu là tôi tôi sẽ dùng 1 mảng thay vì 4-10 mảng con.

4. Code do tôi chỉnh sửa. Tôi không cam kết là tôi làm đúng. Tôi không không nói là tôi biết hết. Tôi không khẳng định là code tôi chỉnh hoàn hảo. Ai muốn thi thố cứ thi thố, tôi không quan tâm. Bạn tự kiểm tra. Dùng được thì dùng, không thì vứt vào sọt rác. Thế thôi.

Mã:

Option Explicit

Sub Create_KML()
    Dim SiteID(), SiteName(), Group_Tinh(), Group_Huyen()   ' , Colour(), Data0(), Data1(), Data2(), Data3(), Data4(), Data5()
    Dim lat(), lon()
    Dim r As Long, aSize As Long, cLimit As Long, dLimit As Long, rLimit As Long, gName As String, tName As String, fName

    'Find the last cell in the x y columns
    cLimit = Range("C6").End(xlDown).Row
    dLimit = Range("D6").End(xlDown).Row
    rLimit = Range("A5").End(xlToRight).Column

    'Test for data completeness
    If cLimit <> dLimit Then
        MsgBox "Error: Number of Lat & Long coordinates do not match. Please correct."
        Exit Sub
    End If

    'Sort for the kml group
    Range(Cells(6, 1), Cells(dLimit, rLimit)).Sort key1:=Range("E6"), order1:=xlAscending, Header:=xlNo

    aSize = cLimit - 5
    ReDim SiteID(aSize), SiteName(aSize), Group_Tinh(aSize), Group_Huyen(aSize)   ' , Colour(aSize), Data0(aSize), Data1(aSize), Data2(aSize), Data3(aSize), Data4(aSize), Data5(aSize)
    ReDim lat(aSize), lon(aSize)

'    Data0(0) = Cells(5, 7).Value
'    Data1(0) = Cells(5, 8).Value
'    Data2(0) = Cells(5, 9).Value
'    Data3(0) = Cells(5, 10).Value
'    Data4(0) = Cells(5, 11).Value
'    Data5(0) = Cells(5, 12).Value

    For r = 1 To aSize
        SiteID(r) = Cells(r + 5, 1).Value
        SiteName(r) = Cells(r + 5, 2).Value
        Group_Tinh(r) = Cells(r + 5, 5).Value
        Group_Huyen(r) = Cells(r + 5, 6).Value
'        Colour(r) = Cells(r + 5, 7).Value
'        Data0(r) = Cells(r + 5, 8).Value
'        Data1(r) = Cells(r + 5, 9).Value
'        Data2(r) = Cells(r + 5, 10).Value
'        Data3(r) = Cells(r + 5, 11).Value
'        Data4(r) = Cells(r + 5, 12).Value
'        Data5(r) = Cells(r + 5, 13).Value
        lat(r) = Cells(r + 5, 3).Value
        lon(r) = Cells(r + 5, 4).Value
    Next r

    ' Fix regional comma/decimal point
    For r = 1 To aSize
        If Abs(lat(r)) > 90 Or Abs(lon(r)) > 180 Then
            MsgBox "Coordinates are out of range"
            Exit Sub
        End If
        lat(r) = Replace(lat(r), ",", ".")
        lon(r) = Replace(lon(r), ",", ".")
    Next r
    
    'Get FileName
    tName = "KML_Export_" & Format(Date, "yyyymmdd")

    fName = Application.GetSaveAsFilename(FileFilter:="KML Files (*.kml), *.kml", Title:="KML File Export", InitialFileName:=tName)
    If fName = False Then Exit Sub
    
    'Open & populate output file
    Open fName For Output As #1

    Call writeKmlInitial(GetFilenameFromPath(fName), 1)
    
    For r = 1 To cLimit - 5
        If Group_Tinh(r) <> gName Then ' Tinh thay doi
            If gName <> "" Then Print #1, "    </Folder>"
            gName = Group_Tinh(r)
            Print #1, "    <Folder>"
            Print #1, "        <name>" & gName & "</name>"
            Print #1, "        <open>1</open>"
            Print #1, "        <gx:balloonVisibility>1</gx:balloonVisibility>"
        End If
        Print #1, "    <Folder>"
        Print #1, "        <name>" & Group_Huyen(r) & "</name>"
        Print #1, "        <open>1</open>"
        Print #1, "        <gx:balloonVisibility>1</gx:balloonVisibility>"
        Print #1, "        <Placemark>"
        Print #1, "            <name>" & SiteID(r) & "</name>"
        Print #1, "            <LookAt>"
        Print #1, "                <longitude>" & lon(r) & "</longitude>"
        Print #1, "                <latitude>" & lat(r) & "</latitude>"
        Print #1, "                <altitude>0</altitude>"
        Print #1, "                <heading>-1.539914092246387e-008</heading>"
        Print #1, "                <tilt>0</tilt>"
        Print #1, "                <range>640383.0131348133</range>"
        Print #1, "                <gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>"
        Print #1, "            </LookAt>"
        Print #1, "            <Point>"
        Print #1, "                <gx:drawOrder>1</gx:drawOrder>"
        Print #1, "                <coordinates>" & lon(r) & "," & lat(r) & ",0</coordinates>"
        Print #1, "            </Point>"
        Print #1, "        </Placemark>"
        Print #1, "    </Folder>"
    Next r
    Print #1, "    </Folder>"
    Print #1, "</Document>"
    Print #1, "</kml>"
    Close #1

    MsgBox "Conversion Complete, see: " & fName
End Sub

quyenpv · 9/9/22

batman1 đã viết:
Bạn phải đọc thật kỹ những lưu ý sau đây.

1. Tôi thú nhận không cần tra tấn là tôi chưa bao giờ làm việc với tập tin KML. Vì thế tôi không biết cấu trúc của KML thế nào. Vì lẽ đó tôi không xem code trong Module11, cụ thể là Sub writeKmlInitial. Tôi không quan tâm nó có ghi đúng cấu trúc của KML hay không. Cũng vì lẽ này những code trong Module1 ghi từng dòng vào tập tin KML (dùng Print) tôi cũng chấp nhận là cấu trúc nó phải thế. Tuy nhiên xét về mặt lôgíc thì code Sub Create_KML có vấn đề. Cái này nó không liên quan gì tới KML, nó thuần túy là lôgíc lập trình. Và tôi chỉnh sửa sai sót của bạn về mặt lôgíc. Tôi nhắc lại: Tôi không biết cấu trúc KML thế nào. Tôi coi như là bạn biết cấu trúc đó.
Code tôi chỉnh sửa ở dưới.

2. Bạn dùng Print nên không ghi được unicode - tiếng Việt.

3. Các việc bạn cần làm.
Tôi mới chỉ chỉnh về mặt lôgíc. Bạn nên dùng FileSystemObject để ghi thay cho Print. Như thế bạn sẽ có tiếng Việt.
Bạn nên viết lại code. Dữ liệu có thể đọc vào mảng trong một nốt nhạc chứ không như code của bạn đọc từng ô từ sheet vào mảng. Mà nếu dùng thì nếu là tôi tôi sẽ dùng 1 mảng thay vì 4-10 mảng con.

4. Code do tôi chỉnh sửa. Tôi không cam kết là tôi làm đúng. Tôi không không nói là tôi biết hết. Tôi không khẳng định là code tôi chỉnh hoàn hảo. Ai muốn thi thố cứ thi thố, tôi không quan tâm. Bạn tự kiểm tra. Dùng được thì dùng, không thì vứt vào sọt rác. Thế thôi.

Mã:

Option Explicit Sub Create_KML() Dim SiteID(), SiteName(), Group_Tinh(), Group_Huyen() ' , Colour(), Data0(), Data1(), Data2(), Data3(), Data4(), Data5() Dim lat(), lon() Dim r As Long, aSize As Long, cLimit As Long, dLimit As Long, rLimit As Long, gName As String, tName As String, fName 'Find the last cell in the x y columns cLimit = Range("C6").End(xlDown).Row dLimit = Range("D6").End(xlDown).Row rLimit = Range("A5").End(xlToRight).Column 'Test for data completeness If cLimit <> dLimit Then MsgBox "Error: Number of Lat & Long coordinates do not match. Please correct." Exit Sub End If 'Sort for the kml group Range(Cells(6, 1), Cells(dLimit, rLimit)).Sort key1:=Range("E6"), order1:=xlAscending, Header:=xlNo aSize = cLimit - 5 ReDim SiteID(aSize), SiteName(aSize), Group_Tinh(aSize), Group_Huyen(aSize) ' , Colour(aSize), Data0(aSize), Data1(aSize), Data2(aSize), Data3(aSize), Data4(aSize), Data5(aSize) ReDim lat(aSize), lon(aSize) ' Data0(0) = Cells(5, 7).Value ' Data1(0) = Cells(5, 8).Value ' Data2(0) = Cells(5, 9).Value ' Data3(0) = Cells(5, 10).Value ' Data4(0) = Cells(5, 11).Value ' Data5(0) = Cells(5, 12).Value For r = 1 To aSize SiteID(r) = Cells(r + 5, 1).Value SiteName(r) = Cells(r + 5, 2).Value Group_Tinh(r) = Cells(r + 5, 5).Value Group_Huyen(r) = Cells(r + 5, 6).Value ' Colour(r) = Cells(r + 5, 7).Value ' Data0(r) = Cells(r + 5, 8).Value ' Data1(r) = Cells(r + 5, 9).Value ' Data2(r) = Cells(r + 5, 10).Value ' Data3(r) = Cells(r + 5, 11).Value ' Data4(r) = Cells(r + 5, 12).Value ' Data5(r) = Cells(r + 5, 13).Value lat(r) = Cells(r + 5, 3).Value lon(r) = Cells(r + 5, 4).Value Next r ' Fix regional comma/decimal point For r = 1 To aSize If Abs(lat(r)) > 90 Or Abs(lon(r)) > 180 Then MsgBox "Coordinates are out of range" Exit Sub End If lat(r) = Replace(lat(r), ",", ".") lon(r) = Replace(lon(r), ",", ".") Next r 'Get FileName tName = "KML_Export_" & Format(Date, "yyyymmdd") fName = Application.GetSaveAsFilename(FileFilter:="KML Files (*.kml), *.kml", Title:="KML File Export", InitialFileName:=tName) If fName = False Then Exit Sub 'Open & populate output file Open fName For Output As #1 Call writeKmlInitial(GetFilenameFromPath(fName), 1) For r = 1 To cLimit - 5 If Group_Tinh(r) <> gName Then ' Tinh thay doi If gName <> "" Then Print #1, " </Folder>" gName = Group_Tinh(r) Print #1, " <Folder>" Print #1, " <name>" & gName & "</name>" Print #1, " <open>1</open>" Print #1, " <gx:balloonVisibility>1</gx:balloonVisibility>" End If Print #1, " <Folder>" Print #1, " <name>" & Group_Huyen(r) & "</name>" Print #1, " <open>1</open>" Print #1, " <gx:balloonVisibility>1</gx:balloonVisibility>" Print #1, " <Placemark>" Print #1, " <name>" & SiteID(r) & "</name>" Print #1, " <LookAt>" Print #1, " <longitude>" & lon(r) & "</longitude>" Print #1, " <latitude>" & lat(r) & "</latitude>" Print #1, " <altitude>0</altitude>" Print #1, " <heading>-1.539914092246387e-008</heading>" Print #1, " <tilt>0</tilt>" Print #1, " <range>640383.0131348133</range>" Print #1, " <gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>" Print #1, " </LookAt>" Print #1, " <Point>" Print #1, " <gx:drawOrder>1</gx:drawOrder>" Print #1, " <coordinates>" & lon(r) & "," & lat(r) & ",0</coordinates>" Print #1, " </Point>" Print #1, " </Placemark>" Print #1, " </Folder>" Next r Print #1, " </Folder>" Print #1, "</Document>" Print #1, "</kml>" Close #1 MsgBox "Conversion Complete, see: " & fName End Sub

Dạ vâng!
Em cám ơn anh, code chạy đúng theo mong muốn rồi ạ. Em đang loạn chỗ vòng lặp ạ
Em cám ơn anh 1 lần nữa ạ

befaint · 9/9/22

quyenpv đã viết:
Dim SiteID(), SiteName(), Group_Tinh(), Group_Huyen(), Colour(), Data0(), Data1(), Data2(), Data3(), Data4(), Data5(), StrLat(), StrLon() As String
Dim Lat(), Lon() As Single

Khai báo biến như thế thì chỉ có biến cuối cùng mới được khai báo kiểu dữ liệu.

Bạn có thể tự kiểm tra:
msgbox typename(SiteID)
msgbox typename(StrLon)

Và bỏ hết mấy cái ngoặc () đi, tự nhiên tốc độ xử lý của code tăng lên cỡ 30-40%, bí kíp được rút ra từ bài học 'xương máu' đấy.

quyenpv · 9/9/22

befaint đã viết:
Khai báo biến như thế thì chỉ có biến cuối cùng mới được khai báo kiểu dữ liệu.

Bạn có thể tự kiểm tra:
msgbox typename(SiteID)
msgbox typename(StrLon)

Và bỏ hết mấy cái ngoặc () đi, tự nhiên tốc độ xử lý của code tăng lên cỡ 30-40%, bí kíp được rút ra từ bài học 'xương máu' đấy.

Ui để em test ạ, cám ơn anh đã chia sẻ ạ

quyenpv · 9/9/22

befaint đã viết:
Khai báo biến như thế thì chỉ có biến cuối cùng mới được khai báo kiểu dữ liệu.

Bạn có thể tự kiểm tra:
msgbox typename(SiteID)
msgbox typename(StrLon)

Và bỏ hết mấy cái ngoặc () đi, tự nhiên tốc độ xử lý của code tăng lên cỡ 30-40%, bí kíp được rút ra từ bài học 'xương máu' đấy.

Anh befaint ơi
Em kiểm tra kỹ thì code đang bị chỗ này anh sửa giúp em với nhé. Ví dụ với mỗi huyện có nhiều hơn 1 vị trí, code vẫn tạo thư mục huyện cho từng vị trí anh ạ thay vì tạo 1 thư mục cho nhiều vị tri

Kết quả đúng nó như thế này ạ

befaint · 9/9/22

quyenpv đã viết:
Em kiểm tra kỹ thì code đang bị chỗ này anh sửa giúp em với nhé. Ví dụ với mỗi huyện có nhiều hơn 1 vị trí, code vẫn tạo thư mục huyện cho từng vị trí anh ạ thay vì tạo 1 thư mục cho nhiều vị tri

Tưởng xong rồi. Em úp file dữ liệu mà một huyện có nhiều hơn 1 vị trí lên nhé.

quyenpv · 9/9/22

befaint đã viết:
Tưởng xong rồi. Em úp file dữ liệu mà một huyện có nhiều hơn 1 vị trí lên nhé.

Dạ anh, em gửi file ạ

befaint · 9/9/22

quyenpv đã viết:
Dạ anh, em gửi file ạ

Mở File này xem đúng ý chưa rồi mới tính tiếp nhé.

quyenpv · 9/9/22

Em mở file lên đang bị lỗi anh ạ, về cấu trúc file kml thì đúng rồi đấy anh

befaint · 9/9/22

quyenpv đã viết:
Em mở file lên đang bị lỗi anh ạ, về cấu trúc file kml thì đúng rồi đấy anh

Tải lại file nhé. Ở bài trên.

quyenpv · 9/9/22

befaint đã viết:
Tải lại file nhé. Ở bài trên.

Dạ đúng rồi anh ạ

befaint · 9/9/22

quyenpv đã viết:
Dạ đúng rồi anh ạ

Sao không chụp cái hình kết quả mở file đó lên bạn, để xem mặt mũi nó ra sao chứ.

quyenpv · 9/9/22

befaint đã viết:
Sao không chụp cái hình kết quả mở file đó lên bạn, để xem mặt mũi nó ra sao chứ.

Dạ em ấy đây ạ. Đẹp lắp anh

namvu230397 · 9/9/22

batman1 đã viết:
Bạn phải đọc thật kỹ những lưu ý sau đây.

1. Tôi thú nhận không cần tra tấn là tôi chưa bao giờ làm việc với tập tin KML. Vì thế tôi không biết cấu trúc của KML thế nào. Vì lẽ đó tôi không xem code trong Module11, cụ thể là Sub writeKmlInitial. Tôi không quan tâm nó có ghi đúng cấu trúc của KML hay không. Cũng vì lẽ này những code trong Module1 ghi từng dòng vào tập tin KML (dùng Print) tôi cũng chấp nhận là cấu trúc nó phải thế. Tuy nhiên xét về mặt lôgíc thì code Sub Create_KML có vấn đề. Cái này nó không liên quan gì tới KML, nó thuần túy là lôgíc lập trình. Và tôi chỉnh sửa sai sót của bạn về mặt lôgíc. Tôi nhắc lại: Tôi không biết cấu trúc KML thế nào. Tôi coi như là bạn biết cấu trúc đó.
Code tôi chỉnh sửa ở dưới.

2. Bạn dùng Print nên không ghi được unicode - tiếng Việt.

3. Các việc bạn cần làm.
Tôi mới chỉ chỉnh về mặt lôgíc. Bạn nên dùng FileSystemObject để ghi thay cho Print. Như thế bạn sẽ có tiếng Việt.
Bạn nên viết lại code. Dữ liệu có thể đọc vào mảng trong một nốt nhạc chứ không như code của bạn đọc từng ô từ sheet vào mảng. Mà nếu dùng thì nếu là tôi tôi sẽ dùng 1 mảng thay vì 4-10 mảng con.

4. Code do tôi chỉnh sửa. Tôi không cam kết là tôi làm đúng. Tôi không không nói là tôi biết hết. Tôi không khẳng định là code tôi chỉnh hoàn hảo. Ai muốn thi thố cứ thi thố, tôi không quan tâm. Bạn tự kiểm tra. Dùng được thì dùng, không thì vứt vào sọt rác. Thế thôi.

Mã:

Option Explicit Sub Create_KML() Dim SiteID(), SiteName(), Group_Tinh(), Group_Huyen() ' , Colour(), Data0(), Data1(), Data2(), Data3(), Data4(), Data5() Dim lat(), lon() Dim r As Long, aSize As Long, cLimit As Long, dLimit As Long, rLimit As Long, gName As String, tName As String, fName 'Find the last cell in the x y columns cLimit = Range("C6").End(xlDown).Row dLimit = Range("D6").End(xlDown).Row rLimit = Range("A5").End(xlToRight).Column 'Test for data completeness If cLimit <> dLimit Then MsgBox "Error: Number of Lat & Long coordinates do not match. Please correct." Exit Sub End If 'Sort for the kml group Range(Cells(6, 1), Cells(dLimit, rLimit)).Sort key1:=Range("E6"), order1:=xlAscending, Header:=xlNo aSize = cLimit - 5 ReDim SiteID(aSize), SiteName(aSize), Group_Tinh(aSize), Group_Huyen(aSize) ' , Colour(aSize), Data0(aSize), Data1(aSize), Data2(aSize), Data3(aSize), Data4(aSize), Data5(aSize) ReDim lat(aSize), lon(aSize) ' Data0(0) = Cells(5, 7).Value ' Data1(0) = Cells(5, 8).Value ' Data2(0) = Cells(5, 9).Value ' Data3(0) = Cells(5, 10).Value ' Data4(0) = Cells(5, 11).Value ' Data5(0) = Cells(5, 12).Value For r = 1 To aSize SiteID(r) = Cells(r + 5, 1).Value SiteName(r) = Cells(r + 5, 2).Value Group_Tinh(r) = Cells(r + 5, 5).Value Group_Huyen(r) = Cells(r + 5, 6).Value ' Colour(r) = Cells(r + 5, 7).Value ' Data0(r) = Cells(r + 5, 8).Value ' Data1(r) = Cells(r + 5, 9).Value ' Data2(r) = Cells(r + 5, 10).Value ' Data3(r) = Cells(r + 5, 11).Value ' Data4(r) = Cells(r + 5, 12).Value ' Data5(r) = Cells(r + 5, 13).Value lat(r) = Cells(r + 5, 3).Value lon(r) = Cells(r + 5, 4).Value Next r ' Fix regional comma/decimal point For r = 1 To aSize If Abs(lat(r)) > 90 Or Abs(lon(r)) > 180 Then MsgBox "Coordinates are out of range" Exit Sub End If lat(r) = Replace(lat(r), ",", ".") lon(r) = Replace(lon(r), ",", ".") Next r 'Get FileName tName = "KML_Export_" & Format(Date, "yyyymmdd") fName = Application.GetSaveAsFilename(FileFilter:="KML Files (*.kml), *.kml", Title:="KML File Export", InitialFileName:=tName) If fName = False Then Exit Sub 'Open & populate output file Open fName For Output As #1 Call writeKmlInitial(GetFilenameFromPath(fName), 1) For r = 1 To cLimit - 5 If Group_Tinh(r) <> gName Then ' Tinh thay doi If gName <> "" Then Print #1, " </Folder>" gName = Group_Tinh(r) Print #1, " <Folder>" Print #1, " <name>" & gName & "</name>" Print #1, " <open>1</open>" Print #1, " <gx:balloonVisibility>1</gx:balloonVisibility>" End If Print #1, " <Folder>" Print #1, " <name>" & Group_Huyen(r) & "</name>" Print #1, " <open>1</open>" Print #1, " <gx:balloonVisibility>1</gx:balloonVisibility>" Print #1, " <Placemark>" Print #1, " <name>" & SiteID(r) & "</name>" Print #1, " <LookAt>" Print #1, " <longitude>" & lon(r) & "</longitude>" Print #1, " <latitude>" & lat(r) & "</latitude>" Print #1, " <altitude>0</altitude>" Print #1, " <heading>-1.539914092246387e-008</heading>" Print #1, " <tilt>0</tilt>" Print #1, " <range>640383.0131348133</range>" Print #1, " <gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>" Print #1, " </LookAt>" Print #1, " <Point>" Print #1, " <gx:drawOrder>1</gx:drawOrder>" Print #1, " <coordinates>" & lon(r) & "," & lat(r) & ",0</coordinates>" Print #1, " </Point>" Print #1, " </Placemark>" Print #1, " </Folder>" Next r Print #1, " </Folder>" Print #1, "</Document>" Print #1, "</kml>" Close #1 MsgBox "Conversion Complete, see: " & fName End Sub

Em làm nhiều với loại file này mà giờ cũng mới biết cấu trúc nó như này bạc ạ. Xưa giờ toàn cho vào google earth hoặc qgis dùng luôn thôi

batman1 · 9/9/22

namvu230397 đã viết:
Em làm nhiều với loại file này mà giờ cũng mới biết cấu trúc nó như này bạc ạ. Xưa giờ toàn cho vào google earth hoặc qgis dùng luôn thôi

Có nhiều công cụ. Nếu bạn tạo trong vd. (chỉ là ví dụ thôi) Goole My Maps thì bạn có thể xuất ra KML hoặc KMZ mà. Chúng là các tập tin văn bản nên mở trong not epad rồi xem được. Trong chủ đề này người ta có các điểm đánh dấu (marker) - tọa độ, nhưng ngoài ra còn có thể có các đường, các hình. Ngay cả với dữ liệu như này thì anh A chỉ cần dạng như code tôi sửa, nhưng anh B lại muốn thêm điều kiện như chủ thớt sau đó thêm. Và code đó làm sao có thể tạo được các đường, các hình khi có dữ liệu. Phải viết lại code thôi. Công cụ thuộc loại chỉ bấm nút, kéo thả v...v thì những ai sống về code họ thu phí chứ không có cho không đâu.

quyenpv · 9/9/22

Anh cho em xin code file anh được không anh

befaint · 10/9/22

quyenpv đã viết:
Dạ em ấy đây ạ. Đẹp lắp anh

Mấy dịch vụ của Google phải có kiến thức và kinh nghiệm thực chiến mới làm nhanh được. Lơ mơ là hỏng hết việc.

Bí kíp làm đẹp ở trong file đính kèm nhé.

Muốn xem code VBA thì gõ mật khẩu: Nho còn non và xanh

quyenpv · 10/9/22

befaint đã viết:
Mấy dịch vụ của Google phải có kiến thức và kinh nghiệm thực chiến mới làm nhanh được. Lơ mơ là hỏng hết việc.

Bí kíp làm đẹp ở trong file đính kèm nhé.

Muốn xem code VBA thì gõ mật khẩu: Nho còn non và xanh

Em cám ơn anh nhiều ạ, chưa chạy được anh ạ. Em đã Enable Marco rồi, tắt đi mở lại vẫn báo lỗi này

Đã vào Enable Marco

quyenpv · 10/9/22

befaint đã viết:
Mấy dịch vụ của Google phải có kiến thức và kinh nghiệm thực chiến mới làm nhanh được. Lơ mơ là hỏng hết việc.

Bí kíp làm đẹp ở trong file đính kèm nhé.

Muốn xem code VBA thì gõ mật khẩu: Nho còn non và xanh

Đúng là còn non và xanh lắm anh!
Ngay cái thoát chế độ Desgin Mode mà còn chưa làm được, các anh chị chỉ bảo thêm nhiều em với ạ

Giúp em sửa lỗi sai vòng lặp khi tạo file kml cho Google Map

Thu nhặt kiến thức

File đính kèm

Thành viên gạo cội

Thu nhặt kiến thức

|||||||||||||

Thu nhặt kiến thức

Thu nhặt kiến thức

|||||||||||||

Thu nhặt kiến thức

File đính kèm

|||||||||||||

File đính kèm

Thu nhặt kiến thức

|||||||||||||

Thu nhặt kiến thức

|||||||||||||

Thu nhặt kiến thức

Thành viên hoạt động

Thành viên gạo cội

Thu nhặt kiến thức

|||||||||||||

File đính kèm

Thu nhặt kiến thức

Thu nhặt kiến thức

Facebook

Group