Hàm gọi title website trong excel

nnduongpt · 10/5/17

Em chào cả nhà, Hôm bữa em có thấy trên facebook có bạn chia sẻ cách gì đó giúp gọi title của website (như ảnh đính kèm). Các anh các chị có ai biết chỉ giúp em với ạ, em xin chân thành cảm ơn!

phulien1902 · 10/5/17

nnduongpt đã viết:
Em chào cả nhà, Hôm bữa em có thấy trên facebook có bạn chia sẻ cách gì đó giúp gọi title của website (như ảnh đính kèm). Các anh các chị có ai biết chỉ giúp em với ạ, em xin chân thành cảm ơn!
View attachment 175432

VBA có được không bạn? Giả sử cột A chứa URL:

PHP:

Sub abc()
    Dim a As Range, i As Long
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        Set a = Range("A" & i)
        If a = "" Then Exit Sub
        Range("B" & i) = Split(a, ".")(1)
    Next i
End Sub

befaint · 10/5/17

phulien1902 đã viết:
VBA có được không bạn? Giả sử cột A chứa URL:

PHP:

Sub abc() Dim a As Range, i As Long For i = 2 To Range("A" & Rows.Count).End(3).Row Set a = Range("A" & i) If a = "" Then Exit Sub Range("B" & i) = Split(a, ".")(1) Next i End Sub

Hình như không phải có đó á...

befaint · 10/5/17

nnduongpt đã viết:
Em chào cả nhà, Hôm bữa em có thấy trên facebook có bạn chia sẻ cách gì đó giúp gọi title của website (như ảnh đính kèm). Các anh các chị có ai biết chỉ giúp em với ạ, em xin chân thành cảm ơn!
View attachment 175432

Có phải cái dòng chữ nằm trong <title>Lấy dòng chữ này</title>
(Là cái dòng hiện ở trên thanh tiêu đề của trình duyệt web)

p/s: Nhìn cái avatar thấy ghê quá ta

híc...

yeudoi · 10/5/17

Cái này là tách chữ chứ nhỉ

befaint · 10/5/17

híc...
Công thức ở bảng tính:

PHP:

=GetTitle(A1)

(Dùng công thức nặng ngỏm luôn...)

PHP:

Option Explicit
'------------------------------------------
Const sTxt As String = "<title"
Const eTxt As String = "</title>"
Const Deli As String = ">"
Const txtMatch As String = "*<title*</title*"
'------------------------------------------
Public Function GetTitle(ByVal link As String) As String
Dim i As Long, j As Long, k As Long, tmpText As String, tmpArr As Variant, tTile As String, m As Long
tmpArr = GetmpXML(link)
For i = LBound(tmpArr) To UBound(tmpArr)
    tmpText = tmpArr(i)
    If tmpText Like txtMatch Then
        j = InStr(tmpText, sTxt)
        k = InStr(tmpText, eTxt)
        tTile = Mid(tmpText, j, k - j)
        m = InStr(tTile, Deli)
        If m Then
            GetTitle = Split(tTile, Deli)(1)
            Exit For
        End If
    End If
Next i
End Function
'------------------------------------------
Public Function GetmpXML(ByVal HTMLlink As String) As Variant
Dim Str As String
With CreateObject("MSXML2.ServerXMLHTTP")
   .Open "GET", HTMLlink, False
   .Send
   Str = .ResponseText
End With
GetmpXML = Split(Str, ChrW(10))
End Function

phulien1902 · 10/5/17

nnduongpt đã viết:
Em chào cả nhà, Hôm bữa em có thấy trên facebook có bạn chia sẻ cách gì đó giúp gọi title của website (như ảnh đính kèm). Các anh các chị có ai biết chỉ giúp em với ạ, em xin chân thành cảm ơn!
View attachment 175432

VBA có được không bạn? Giả sử cột A chứa URL:

PHP:

Sub abc()
    Dim a As Range, i As Long
    For i = 2 To Range("A" & Rows.Count).End(3).Row
        Set a = Range("A" & i)
        If a = "" Then Exit Sub
        Range("B" & i) = Split(a, ".")(1)
    Next i
End Sub

befaint đã viết:

híc...
Công thức ở bảng tính:

PHP:

=GetTitle(A1)

(Dùng công thức nặng ngỏm luôn...)

PHP:

Option Explicit
'------------------------------------------
Const sTxt As String = "<title"
Const eTxt As String = "</title>"
Const Deli As String = ">"
Const txtMatch As String = "*<title*</title*"
'------------------------------------------
Public Function GetTitle(ByVal link As String) As String
Dim i As Long, j As Long, k As Long, tmpText As String, tmpArr As Variant, tTile As String, m As Long
tmpArr = GetmpXML(link)
For i = LBound(tmpArr) To UBound(tmpArr)
    tmpText = tmpArr(i)
    If tmpText Like txtMatch Then
        j = InStr(tmpText, sTxt)
        k = InStr(tmpText, eTxt)
        tTile = Mid(tmpText, j, k - j)
        m = InStr(tTile, Deli)
        If m Then
            GetTitle = Split(tTile, Deli)(1)
            Exit For
        End If
    End If
Next i
End Function
'------------------------------------------
Public Function GetmpXML(ByVal HTMLlink As String) As Variant
Dim Str As String
With CreateObject("MSXML2.ServerXMLHTTP")
   .Open "GET", HTMLlink, False
   .Send
   Str = .ResponseText
End With
GetmpXML = Split(Str, ChrW(10))
End Function

Cách của bạn hay quá!

phulien1902 · 10/5/17

Cách của bạn hay quá!

phulien1902 · 10/5/17

Cách của befaint hay quá!

nnduongpt · 10/5/17

phulien1902 đã viết:
VBA có được không bạn? Giả sử cột A chứa URL:

PHP:

Sub abc() Dim a As Range, i As Long For i = 2 To Range("A" & Rows.Count).End(3).Row Set a = Range("A" & i) If a = "" Then Exit Sub Range("B" & i) = Split(a, ".")(1) Next i End Sub

Cách của bạn hay quá!

Cảm ơn bác nhiều, nhưng mà VBA thì em chẳng biết gì. Có cách nào đơn giản hơn không ạ

nnduongpt · 10/5/17

befaint đã viết:
Có phải cái dòng chữ nằm trong <title>Lấy dòng chữ này</title>
(Là cái dòng hiện ở trên thanh tiêu đề của trình duyệt web)

p/s: Nhìn cái avatar thấy ghê quá ta híc...

Dạ đúng rồi bác, nó còn gọi là tiêu đề web đó ạ

PS: Avatar nhìn đáng sợ vậy ạ

befaint · 11/5/17

nnduongpt đã viết:
Cảm ơn bác nhiều, nhưng mà VBA thì em chẳng biết gì. Có cách nào đơn giản hơn không ạ

Có cách chứ. Mình mở từng địa chỉ web đó lên, nhìn tiêu đề mỗi trang web là gì rồi gõ gõ vào cột kế bên.

P/s: avatar nhìn như *tướng ấy

)

nnduongpt · 11/5/17

befaint đã viết:
Có cách chứ. Mình mở từng địa chỉ web đó lên, nhìn tiêu đề mỗi trang web là gì rồi gõ gõ vào cột kế bên.

P/s: avatar nhìn như *tướng ấy )

Cách của bác hay quá, bác không nói thì em không thể nghĩ ra được đâu

(

Ps: Avatar Em coi đó là lời khen nhé

quocgiacan · 11/5/17

befaint đã viết:

híc...
Công thức ở bảng tính:

PHP:

=GetTitle(A1)

(Dùng công thức nặng ngỏm luôn...)

PHP:

Option Explicit
'------------------------------------------
Const sTxt As String = "<title"
Const eTxt As String = "</title>"
Const Deli As String = ">"
Const txtMatch As String = "*<title*</title*"
'------------------------------------------
Public Function GetTitle(ByVal link As String) As String
Dim i As Long, j As Long, k As Long, tmpText As String, tmpArr As Variant, tTile As String, m As Long
tmpArr = GetmpXML(link)
For i = LBound(tmpArr) To UBound(tmpArr)
    tmpText = tmpArr(i)
    If tmpText Like txtMatch Then
        j = InStr(tmpText, sTxt)
        k = InStr(tmpText, eTxt)
        tTile = Mid(tmpText, j, k - j)
        m = InStr(tTile, Deli)
        If m Then
            GetTitle = Split(tTile, Deli)(1)
            Exit For
        End If
    End If
Next i
End Function
'------------------------------------------
Public Function GetmpXML(ByVal HTMLlink As String) As Variant
Dim Str As String
With CreateObject("MSXML2.ServerXMLHTTP")
   .Open "GET", HTMLlink, False
   .Send
   Str = .ResponseText
End With
GetmpXML = Split(Str, ChrW(10))
End Function

Hay quá em!
Cho anh "hùn" 1 chút "vốn" vào cột B nha, coi như góp vui "văn nghệ" với anh em. %$$

Chúc anh em ngày thiệt vui.

ndu96081631 · 12/5/17

Góp vui với code này:

Mã:

Function WebTitle(ByVal sURL As String) As String
  Dim sTmp, lPos, aURL, itemURL
  On Error Resume Next
  If UCase(Left(sURL, 4)) <> "HTTP" Then
    aURL = Array("http://" & sURL, "https://" & sURL)
  Else
    aURL = Array(sURL)
  End If
  For Each itemURL In aURL
    With CreateObject("MSXML2.ServerXMLHTTP")
      .Open "GET", itemURL, False
      .Send ""
      sTmp = .ResponseText
    End With
    If Len(sTmp) Then Exit For
  Next
  If Len(sTmp) Then
    lPos = InStr(1, UCase(sTmp), "<TITLE>")
    If lPos Then
      sTmp = Mid(sTmp, lPos + 7)
      lPos = InStr(1, UCase(sTmp), "</TITLE>")
      If lPos Then WebTitle = Mid(sTmp, 1, lPos - 1)
    End If
  End If
End Function

Đề phòng trường hợp người dùng gõ không đầy đủ (gõ www.giaiphapexcel.com thay vì phải gõ đầy đủ http://www.giaiphapexcel.com)
Ngoài ra trong trường hợp người dùng gõ không đầy đủ thì ta cũng không biết chắc tiền tố đầu là http hay https
Code trên sẽ giải quyết các vấn đề đã nêu
(không biết còn lỗi nào nữa không)

befaint · 12/5/17

ndu96081631 đã viết:
PHP:

lPos = InStr(1, UCase(sTmp), "<TITLE>")

Facebook hơi khác chút chỗ này nên code của anh: lPos sẽ không có.

PHP:

<title id="pageTitle">Chào mừng bạn đến với Facebook - Đăng nhập, Đăng ký hoặc Tìm hiểu thêm</title>

<title id="pageTitle">Facebook - Log In or Sign Up</title>

ndu96081631 · 12/5/17

befaint đã viết:
Facebook hơi khác chút chỗ này nên code của anh: lPos sẽ không có.

PHP:

<title id="pageTitle">Chào mừng bạn đến với Facebook - Đăng nhập, Đăng ký hoặc Tìm hiểu thêm</title> <title id="pageTitle">Facebook - Log In or Sign Up</title>

Cảm ơn bạn phát hiện (tôi cũng không rành mấy vụ này lắm)
Giờ sửa lại chút:

Mã:

Function WebTitle(ByVal sURL As String) As String
  Dim sTmp, lPos, aURL, itemURL
  On Error Resume Next
  If UCase(Left(sURL, 4)) <> "HTTP" Then
    aURL = Array("http://" & sURL, "https://" & sURL)
  Else
    aURL = Array(sURL)
  End If
  For Each itemURL In aURL
    With CreateObject("MSXML2.ServerXMLHTTP")
      .Open "GET", itemURL, False
      .Send ""
      sTmp = .ResponseText
    End With
    If Len(sTmp) Then Exit For
  Next
  If Len(sTmp) Then
    lPos = InStr(1, UCase(sTmp), "<TITLE")
    If lPos Then
      sTmp = Mid(sTmp, lPos)
      lPos = InStr(1, sTmp, ">")
      sTmp = Mid(sTmp, lPos + 1)
      lPos = InStr(1, UCase(sTmp), "</TITLE>")
      If lPos Then WebTitle = Mid(sTmp, 1, lPos - 1)
    End If
  End If
End Function

Bạn kiểm tra lại giúp

Hàm gọi title website trong excel

Thành viên chính thức

GPE - My love

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

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

Thành viên gắn bó

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

File đính kèm

GPE - My love

GPE - My love

GPE - My love

Thành viên chính thức

Thành viên chính thức

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

Thành viên chính thức

-⍟-

File đính kèm

Huyền thoại GPE

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

Huyền thoại GPE

Facebook

Group