Nhờ các bạn giải thích hộ mình đoạn code VBA này với. họ gửi cho mình mà mình không đọc không hiểu gì cả. (1 người xem)

[muamua6]

Function CatTen(str As String, ch As String) As String
Dim mlen As Long
Dim i As Long
mlen = Len(str)
For i = mlen To 1 Step -1
If Mid(str, i, 1) = ch Then
Exit For
End If
Next
If i <> 0 Then
CatTen = Trim(Mid(str, i + 1, mlen - i))
Else
CatTen = Trim(str)
End If
End Function
Function CatHo(str As String, ch As String) As String
Dim mlen As Long
Dim i As Long
mlen = Len(str)
For i = 1 To mlen
If Mid(str, i, 1) = ch Then
Exit For
End If
Next
If i <> 0 Then
CatHo = Trim(Mid(str, 1, i - 1))
Else
CatHo = Trim(str)
End If
End Function
Function LayTF(st As String)
Dim s As String
s = CatTen(st, "\")
s = CatHo(s, ".")
LayTF = s
End Function
Function ConvertToUnSign(ByVal sContent As String) As String
Dim i As Long
Dim intCode As Long
Dim sChar As String
Dim sConvert As String
ConvertToUnSign = AscW(sContent)
For i = 1 To Len(sContent)
sChar = Mid(sContent, i, 1)
If sChar <> "" Then
intCode = AscW(sChar)
End If

Select Case intCode
Case 273
sConvert = sConvert & "d"
Case 272
sConvert = sConvert & "D"
Case 224, 225, 226, 227, 259, 7841, 7843, 7845, 7847, 7849, 7851, 7853, 7855, 7857, 7859, 7861, 7863
sConvert = sConvert & "a"
Case 192, 193, 194, 195, 258, 7840, 7842, 7844, 7846, 7848, 7850, 7852, 7854, 7856, 7858, 7860, 7862
sConvert = sConvert & "A"
Case 232, 233, 234, 7865, 7867, 7869, 7871, 7873, 7875, 7877, 7879
sConvert = sConvert & "e"
Case 200, 201, 202, 7864, 7866, 7868, 7870, 7872, 7874, 7876, 7878
sConvert = sConvert & "E"
Case 236, 237, 297, 7881, 7883
sConvert = sConvert & "i"
Case 204, 205, 296, 7880, 7882
sConvert = sConvert & "I"
Case 242, 243, 244, 245, 417, 7885, 7887, 7889, 7891, 7893, 7895, 7897, 7899, 7901, 7903, 7905, 7907
sConvert = sConvert & "o"
Case 210, 211, 212, 213, 416, 7884, 7886, 7888, 7890, 7892, 7894, 7896, 7898, 7900, 7902, 7904, 7906
sConvert = sConvert & "O"
Case 249, 250, 361, 432, 7909, 7911, 7913, 7915, 7917, 7919, 7921
sConvert = sConvert & "u"
Case 217, 218, 360, 431, 7908, 7910, 7912, 7914, 7916, 7918, 7920
sConvert = sConvert & "U"
Case 253, 7923, 7925, 7927, 7929
sConvert = sConvert & "y"
Case 221, 7922, 7924, 7926, 7928
sConvert = sConvert & "Y"
Case Else
sConvert = sConvert & sChar
End Select
Next
ConvertToUnSign = sConvert
End Function
Function UniVba(TxtUni As String) As String
If TxtUni = "" Then
UniVba = ""
Else
TxtUni = TxtUni & " "
'If AscW(Left(TxtUni, 1)) < 256 Then UniVba = """"
For n = 1 To Len(TxtUni) - 1
uni1 = Mid(TxtUni, n, 1)
uni2 = AscW(Mid(TxtUni, n + 1, 1))
If AscW(uni1) > 255 And uni2 > 255 Then
'UniVba = UniVba & "ChrW(" & AscW(uni1) & ") & "
UniVba = UniVba & "&#" & AscW(uni1) & ";"
ElseIf AscW(uni1) > 255 And uni2 < 256 Then
'UniVba = UniVba & "ChrW(" & AscW(uni1) & ") & """
UniVba = UniVba & "&#" & AscW(uni1) & ";"
ElseIf AscW(uni1) < 256 And uni2 > 255 Then
'UniVba = UniVba & uni1 & """ & "
UniVba = UniVba & uni1
Else
UniVba = UniVba & uni1
End If
Next
If Right(UniVba, 4) = " & """ Then
UniVba = Mid(UniVba, 1, Len(UniVba) - 4)
Else
'UniVba = UniVba & """"
UniVba = UniVba
End If
End If
End Function
Sub KML_converter()
'--------------------------------------

Dim password As Variant
password = Application.InputBox("Enter Password- Nguyen Gia Thanh", "Password Protected")

Select Case password
Case Is = False
MsgBox "Chua nhap mat ma, khong the dang nhap chuong trinh..."
ThisWorkbook.Close False
'do nothing
Case Is = "123456789"
MsgBox "Dang nhap thanh cong! ", , "Thông báo"
Case Else
MsgBox "Mat ma sai, khong the dang nhap chuong trinh..."
ThisWorkbook.Close False
End Select





'-------------------------------------------------
Dim lOutputFile As Long
Dim sitename, BD As Range
Dim header As Range
Dim layername, st, Folder As String
Dim Filename As String
Dim i, j, nameOffset, LongOffset, LatOffset, ColorOffsetAs, XaOffset As Integer
Dim Socot As Integer
Dim Cot(100) As String
Dim Mau(5)
Mau(0) = ThisWorkbook.Worksheets("QuyDinhMau").Range("C2").Value
Mau(1) = ThisWorkbook.Worksheets("QuyDinhMau").Range("C3").Value
Mau(2) = ThisWorkbook.Worksheets("QuyDinhMau").Range("C4").Value
Mau(3) = ThisWorkbook.Worksheets("QuyDinhMau").Range("C5").Value
Mau(4) = ThisWorkbook.Worksheets("QuyDinhMau").Range("C6").Value

Set BD = ThisWorkbook.Worksheets("Mau_KML").Range("A1")
Set sitename = ThisWorkbook.Worksheets(1).Range("A5")
Set header = ThisWorkbook.Worksheets(1).Range("A4")
' Get a valid file number
lOutputFile = FreeFile
' Create a new file for output
'Filename = Left(ThisWorkbook.Name, InStr(ThisWorkbook.Name, ".") - 1) & ".kml"

Filename = WorksheetFunction.Substitute(ConvertToUnSign(sitename.Offset(1, 5).Value), " ", "_") & "_" & Format(Now(), "yyyy_mm_dd") + ".kml"
fileSaveName = Application.GetSaveAsFilename( _
InitialFileName:=Filename, _
fileFilter:="KML Files (*.kml), *.kml")

Open fileSaveName For Output As #lOutputFile
' Loop until there isn't any data in the first column
'layername = InputBox("Nhap ten layer name trong Google Earth")
i = 0
Do While (header.Offset(0, i).Value <> "")
'MsgBox UniVba(header.Offset(0, i).Value)
Cot(i) = UniVba(header.Offset(0, i).Value)
If UCase(Cot(i)) = "U" Then nameOffset = i
If UCase(Cot(i)) = "LONGITUDE" Then LongOffset = i
If UCase(Cot(i)) = "LATITUDE" Then LatOffset = i
If UCase(Cot(i)) = "COLOR" Then ColorOffset = i
If UCase(Cot(i)) = "CCAO" Then XaOffset = i
Socot = i
i = i + 1
Loop
'MsgBox (nameOffset)
'MsgBox (LongOffset)
'MsgBox (LatOffset)
'Print #lOutputFile, "<?xml version='1.0' encoding='UTF-8'?>"
'Print #lOutputFile, "<kml>"
Print #lOutputFile, "<?xml version='1.0' encoding='UTF-8'?>"
Print #lOutputFile, "<kml>"
Print #lOutputFile, "<Document>"
Print #lOutputFile, "<name>" & LayTF(Filename) & "</name>"
For i = 0 To 4
For j = 0 To 33
If j = 0 Or j = 3 Or j = 7 Or j = 10 Or j = 22 Then
st = BD.Offset(j, 0).Value & Trim(str(i + 1)) & BD.Offset(j, 2).Value
Else
If j = 14 Or j = 26 Then
st = BD.Offset(j, 0).Value & Mau(i) & BD.Offset(j, 2).Value
Else
st = BD.Offset(j, 0).Value & BD.Offset(j, 1).Value & BD.Offset(j, 2).Value
End If
End If
Print #lOutputFile, st
Next j
Next i

layername = UniVba(Trim(sitename.Offset(0, XaOffset).Value))
Print #lOutputFile, "<Folder>"
Print #lOutputFile, "<name>" & layername & "</name>"

Do While (sitename.Value <> "")
On Error Resume Next
If layername <> UniVba(Trim(sitename.Offset(0, XaOffset).Value)) Then
Print #lOutputFile, "</Folder>"
Print #lOutputFile, "<Folder>"
layername = UniVba(Trim(sitename.Offset(0, XaOffset).Value))
Print #lOutputFile, "<name>" & layername & "</name>"
End If
Print #lOutputFile, "<Placemark>"
Print #lOutputFile, "<name>"
Print #lOutputFile, sitename.Offset(0, nameOffset).Value
Print #lOutputFile, "</name>"
Print #lOutputFile, "<description>"
Print #lOutputFile, "<![CDATA[<br><br><br>"
Print #lOutputFile, "<table border="; 1; " padding="; 0; ">"
For i = 0 To Socot
Print #lOutputFile, "<tr><td>" & Cot(i) & "</td><td>" & UniVba(sitename.Offset(0, i).Value) & "</td></tr>"
Next i

Print #lOutputFile, "</table>"
Print #lOutputFile, "]]>"
'Print #lOutputFile, header.Value & ": " & sitename.Offset(0, 3).Value
'Print #lOutputFile, header.Offset(0, 1).Value & ": " & sitename.Offset(0, 4).Value
'Print #lOutputFile, header.Offset(0, 2).Value & ": " & sitename.Offset(0, 5).Value
'Print #lOutputFile, header.Offset(0, 3).Value & ": " & sitename.Offset(0, 6).Value
'Print #lOutputFile, header.Offset(0, 4).Value & ": " & sitename.Offset(0, 7).Value
'Print #lOutputFile, header.Offset(0, 5).Value & ": " & sitename.Offset(0, 8).Value
'Print #lOutputFile, header.Offset(0, 6).Value & ": " & sitename.Offset(0, 9).Value
'Print #lOutputFile, header.Offset(0, 7).Value & ": " & sitename.Offset(0, 10).Value
'Print #lOutputFile, header.Offset(0, 8).Value & ": " & sitename.Offset(0, 11).Value
'Print #lOutputFile, header.Offset(0, 9).Value & ": " & sitename.Offset(0, 12).Value
'Print #lOutputFile, header.Offset(0, 10).Value & ": " & sitename.Offset(0, 13).Value
'Print #lOutputFile, header.Offset(0, 11).Value & ": " & sitename.Offset(0, 14).Value
'Print #lOutputFile, header.Offset(0, 12).Value & ": " & sitename.Offset(0, 15).Value
Print #lOutputFile, "</description>"
Print #lOutputFile, "<LookAt>"
Print #lOutputFile, "<longitude>" & sitename.Offset(0, LongOffset).Value & "</longitude>"
Print #lOutputFile, "<latitude>" & sitename.Offset(0, LatOffset).Value & "</latitude>"
'Print #lOutputFile, "<range>1000</range>"
'-----------------------------
'Print #lOutputFile, "<Style><LineStyle><color>FF00FF00</color><width>2</width></LineStyle></Style>"
'Print #lOutputFile, "<LineString><tessellate>1</tessellate>"
'Print #lOutputFile, "<coordinates>"
'-------------------------
Print #lOutputFile, "<visibility>1</visibility>"
Print #lOutputFile, "<open>0</open>"
Print #lOutputFile, "<tilt>0</tilt>"
Print #lOutputFile, "<heading>0</heading>"
Print #lOutputFile, "</LookAt>"
Print #lOutputFile, "<styleUrl>" & sitename.Offset(0, ColorOffset).Value & "</styleUrl>"
Print #lOutputFile, "<Point>"
Print #lOutputFile, "<extrude>1</extrude>"
Print #lOutputFile, "<altitudeMode>relativeToGround</altitudeMode>"
Print #lOutputFile, "<coordinates>" & sitename.Offset(0, LongOffset).Value & "," & sitename.Offset(0, LatOffset).Value & ",0</coordinates>"
Print #lOutputFile, "</Point>"
Print #lOutputFile, "</Placemark>"

Set sitename = sitename.Offset(1, 0)
Loop

Print #lOutputFile, "</Folder>"
Print #lOutputFile, "</Document>"
Print #lOutputFile, "</kml>"

Close lOutputFile
MsgBox ("Da chuyen doi xong !")
End Sub


Sub t()
MsgBox (WorksheetFunction.Substitute("A B", " ", "_"))
End Sub

 

[SA_DQ]

. . . họ gửi cho mình mà mình không đọc không hiểu gì cả.

/(hông đọc thì không hiểu là bình thường mà bạn; Không đọc mà hiểu thì mới là chuyện lạ trên GPE!

 

[Nguyễn Duy Tuân]

Nếu bạn không biết gì về VBA thì thôi bỏ qua. Còn biết một chút thì cứ lấy hàm mà ứng dụng. Các hàm như sau:
1. CatTen() : hàm lấy tên của chuỗi "Họ Và Tên"
2. CatHo(): hàm lấy họ của chuỗi "Họ Và Tên"
(Cả hai hàm trên tác giả phải viết vòng lặp, không tốt bằng sử dụng hàm InsStrRev() cảu VBA)
3. LayTF(): cắt chuỗi khi tìm "/" và "."
=LayTF("Nguyễn Duy Tuân\ ABC") trả về " ABC"
=LayTF("Nguyễn Duy Tuân. ABC") trả về "Nguyễn Duy Tuân"
4. ConvertToUnSign() : xóa ký tự có dấu. Ví dụ
=ConvertToUnSign("Nguyễn Duy Tuân") trả về "Nguyen Duy Tuan"
5. UniVba(): chuyển đổi chuỗi unicode về chuỗi ghéo với mã kỹ tự, để biểu lưu trong code VBA.
= UniVba("Nguyễn Duy Tuân") trả về "Nguy&#7877;n Duy Tuân"
Kiểu chuỗi này hiển thị chữ có dấu trong HTML hoặc các trình soạn thảo khác.
6. KML_converter() là macro chính ứng dụng các hàm trên để tạo file có cấu trúc HTML, lưu tên file có đuôi "*.kml". Nội dung tạo dựa trên các sheet trong file Excel.

Tóm lại, đống code trên mục đích để tự tạo một file mà nội dung của nó có cấu trúc ngôn ngữ HTML.

 

[hoahuongduong1986]

Nếu bạn không biết gì về VBA thì thôi bỏ qua. Còn biết một chút thì cứ lấy hàm mà ứng dụng. Các hàm như sau:
1. CatTen() : hàm lấy tên của chuỗi "Họ Và Tên"
2. CatHo(): hàm lấy họ của chuỗi "Họ Và Tên"
(Cả hai hàm trên tác giả phải viết vòng lặp, không tốt bằng sử dụng hàm InsStrRev() cảu VBA)
3. LayTF(): cắt chuỗi khi tìm "/" và "."
=LayTF("Nguyễn Duy Tuân\ ABC") trả về " ABC"
=LayTF("Nguyễn Duy Tuân. ABC") trả về "Nguyễn Duy Tuân"
4. ConvertToUnSign() : xóa ký tự có dấu. Ví dụ
=ConvertToUnSign("Nguyễn Duy Tuân") trả về "Nguyen Duy Tuan"
5. UniVba(): chuyển đổi chuỗi unicode về chuỗi ghéo với mã kỹ tự, để biểu lưu trong code VBA.
= UniVba("Nguyễn Duy Tuân") trả về "Nguy&#7877;n Duy Tuân"
Kiểu chuỗi này hiển thị chữ có dấu trong HTML hoặc các trình soạn thảo khác.
6. KML_converter() là macro chính ứng dụng các hàm trên để tạo file có cấu trúc HTML, lưu tên file có đuôi "*.kml?". Nội dung tạo dựa trên các sheet trong file Excel.

Tóm lại, đống code trên mục đích để tự tạo một file mà nội dung của nó có cấu trúc ngôn ngữ HTML.

Người hỏi không bình thường anh ạ.haha. Chắc do covid trong nhà nhiều quá.

 

[befaint]

Function UniVba(TxtUni As String) As String

Cái này là để chuyển các ký tự có code > 255 sang HTML Character Entities (Entity Number)

 

[muamua6]

Hay quá! Cảm ơn bạn nhiều nhé .

Nếu bạn không biết gì về VBA thì thôi bỏ qua. Còn biết một chút thì cứ lấy hàm mà ứng dụng. Các hàm như sau:
1. CatTen() : hàm lấy tên của chuỗi "Họ Và Tên"
2. CatHo(): hàm lấy họ của chuỗi "Họ Và Tên"
(Cả hai hàm trên tác giả phải viết vòng lặp, không tốt bằng sử dụng hàm InsStrRev() cảu VBA)
3. LayTF(): cắt chuỗi khi tìm "/" và "."
=LayTF("Nguyễn Duy Tuân\ ABC") trả về " ABC"
=LayTF("Nguyễn Duy Tuân. ABC") trả về "Nguyễn Duy Tuân"
4. ConvertToUnSign() : xóa ký tự có dấu. Ví dụ
=ConvertToUnSign("Nguyễn Duy Tuân") trả về "Nguyen Duy Tuan"
5. UniVba(): chuyển đổi chuỗi unicode về chuỗi ghéo với mã kỹ tự, để biểu lưu trong code VBA.
= UniVba("Nguyễn Duy Tuân") trả về "Nguy&#7877;n Duy Tuân"
Kiểu chuỗi này hiển thị chữ có dấu trong HTML hoặc các trình soạn thảo khác.
6. KML_converter() là macro chính ứng dụng các hàm trên để tạo file có cấu trúc HTML, lưu tên file có đuôi "*.kml". Nội dung tạo dựa trên các sheet trong file Excel.

Tóm lại, đống code trên mục đích để tự tạo một file mà nội dung của nó có cấu trúc ngôn ngữ HTML.