[tool-macro] check deadlink

[ruahiphop]

chào các anh chị,
hiện tại em bị sếp giao công việc nghiên cứu làm về 1 cái tool cho excel , hạn thì gần kề mà em thì mới chưa biết gì về vba các anh chị vui lòng hướng dẫn giúp em với. Dưới đây là vấn đề của em
Viết 1 cái marco trên excel để thực hiện các loại check sau


1. Check xem có link nào trong workbook đang ko được set hoặc ko hoạt động ko và đưa ra thông báo? (check link web và tới vị trí bất kì trên workbook )

2. Đưa hết con trỏ về cell đầu tiên bên trái trên cùng
3. Set font size, font chữ, font color theo giá trị nhập vào

Em xin cám ơn

 

[ndu96081631]

chào các anh chị,
hiện tại em bị sếp giao công việc nghiên cứu làm về 1 cái tool cho excel , hạn thì gần kề mà em thì mới chưa biết gì về vba các anh chị vui lòng hướng dẫn giúp em với. Dưới đây là vấn đề của em
Viết 1 cái marco trên excel để thực hiện các loại check sau


1. Check xem có link nào trong workbook đang ko được set hoặc ko hoạt động ko và đưa ra thông báo? (check link web và tới vị trí bất kì trên workbook )

2. Đưa hết con trỏ về cell đầu tiên bên trái trên cùng
3. Set font size, font chữ, font color theo giá trị nhập vào

Em xin cám ơn

Để kiểm tra 1 Hyperlink có hoạt động hay không phải qua 3 công đoạn
1> Kiểm tra liên kết bên trong workbook

Function DocHyperlinkExists(ByVal rLink As Range) As Boolean
  Dim cLink As Hyperlink, tmpAdd As String
  On Error Resume Next
  If rLink.Hyperlinks(1).SubAddress <> "" Then
    tmpAdd = Range(rLink.Hyperlinks(1).SubAddress).Address
    DocHyperlinkExists = tmpAdd <> ""
  End If
End Function

2> Kiểm tra liên kết đến file, folder

Function FileHyperlinkExists(ByVal rLink As Range) As Boolean
  Dim chkDir As String
  On Error Resume Next
  If rLink.Hyperlinks(1).Address <> "" Then
    If Left(rLink.Hyperlinks(1).Address, 4) <> "http" Then
      chkDir = CreateObject("Scripting.FileSystemObject").FileExists(rLink.Hyperlinks(1).Address)
      FileHyperlinkExists = chkDir <> ""
    End If
  End If
End Function

3> Kiểm tra liên kết đến các trang Web

Function URLHyperlinkExists(ByVal rLink As Range) As Boolean
  Dim URL As String
  Application.Volatile
  On Error Resume Next
  URL = rLink.Hyperlinks(1).Address
  If Left(UCase(URL), 7) <> "HTTP://" Then URL = "http://" & URL
  With CreateObject("MSXML2.XMLHTTP")
    .Open "HEAD", URL, False: .send
    URLHyperlinkExists = .Status = 200
  End With
End Function

Nếu 3 lần kiểm tra đều cho kết quả = FALSE thì liên kết ấy không tồn tại
--------------------------
Lưu ý: Riêng phần kiểm tra liên kết trong hàm HYPERLINK tôi vẫn chưa biết cách nào (chẳng lẽ phải "moi" công thức ra kiểm tra?)

 

[ruahiphop]

Em nghĩ là phải moi ra kiểm tra anh ạ T_T

Em cũng đang phân vân chưa biết phải làm thế nào
Em cũng định viết như anh phân tích
Step 1
Check link có dẫn đến web hay không

Private Function CheckLinkWeb(ByVal strUrl As String) As Boolean

    On Error GoTo ErrorHandler
    Dim objRequest As MSXML2.XMLhttp
    Set objRequest = New MSXML2.XMLhttp
    With objRequest
    .Open "HEAD", strUrl, False
    .send
    CheckLinkWeb = True

    Exit Function
    End With
ErrorHandler:
    CheckLinkWeb = False

End Function

Step 2 check trong workbook , cái này nó hơi lằng ngoằng em mới chỉ có ý tưởng nhưng chưa biết phải dùng function nào , vì em chưa biết nhiều về VB ko biết có những function nào dựng sẵn trợ giúp cho em trong việc dưới đây hay không

Việc check address trong workbook bao gồm
1/ check tại vị trí sheet hiện hành. có nghĩa là nó sẽ link đến 1 vị trí nào đó tại Activesheet. ở check này thì address có dạng ABC123. nếu check ở cái này thì em đang nghĩ là get Nội dụng lưu trữ ở cái vị trí đó ra nếu = null thì báo là link không tồn tại và ngược lại
2/ check tại other sheet. có nghĩa là nó sẽ link đến 1 vị trí ở sheets khác. ở check này thì address của hyperlink có dang SheetName!ABC123. em dự định là sẽ tách cái Sheetname ra kiểm tra . nếu Sheetname tồn tại thì em sẽ check đến nội dung chứa trong địa chỉ "SheetName!ABC123" như ở currentsheets.
3/ còn việc check đến folder em nghĩ nên bỏ qua, vì giả sử có 1 folder tồn tại trên máy người làm file nhưng lại ko tồn tại ở máy người đọc, lúc check thì ok nhưng qua bên kia thì ko có thì T_T

em nghĩ cách này của em hơi rắc rối các bạn có gì comment giúp em với.
Em cám ơn

 

[ndu96081631]

1/ check tại vị trí sheet hiện hành. có nghĩa là nó sẽ link đến 1 vị trí nào đó tại Activesheet. ở check này thì address có dạng ABC123. nếu check ở cái này thì em đang nghĩ là get Nội dụng lưu trữ ở cái vị trí đó ra nếu = null thì báo là link không tồn tại và ngược lại
2/ check tại other sheet. có nghĩa là nó sẽ link đến 1 vị trí ở sheets khác. ở check này thì address của hyperlink có dang SheetName!ABC123. em dự định là sẽ tách cái Sheetname ra kiểm tra . nếu Sheetname tồn tại thì em sẽ check đến nội dung chứa trong địa chỉ "SheetName!ABC123" như ở currentsheets.

2 bước này chung nhau thôi... đằng nào thì Hyperlink ấy cũng sẽ liên kết đến 1 địa chỉ cell nào đó ---> Lấy địa chỉ này xem có tồn tại hay không là được rồi
Ví dụ:
- Hyperlink ở A1 có địa chỉ link là IW1 ---> Nếu file được tạo từ Excel 2003 thì địa chỉ IW1 sẽ xem là không tồn tai
- Hyperlink ở A1 có địa chỉ link là Sheet4!C5 ---> Địa chỉ này sẽ xem như là không tồn tại nếu trong Workbook không có sheet4
Đó chính là giải thuật tại hàm đầu tiên
----------------------

Em nghĩ là phải moi ra kiểm tra anh ạ T_T

Dù "moi" công thức thì cũng chưa chắc dễ ăn đâu. Xui xẻo cái công thức ấy là 1 dạng công thức kết hợp gồm nhiều hàm thì dù bạn biết chắc trong công thức ấy có hàm HYPERLINK cũng chẳng biết đường nào mà lần

 

[ruahiphop]

Em cà rốt quá, anh cho em hỏi cái 1 làm việc như thế nào
em lấy 1 range bằng lệnh này

Dim rSelect: rSelect = Selection.Address(ReferenceStyle:=xlA1, _
RowAbsolute:=False, ColumnAbsolute:=False)
và em truyền vào như thế này thì nó ko cho báo lỗi object required
If DocHyperlinkExists(rSelect) = False Then
MsgBox ("not avaible")
Else
MsgBox ("avaible")
End If

 

[ndu96081631]

Em cà rốt quá, anh cho em hỏi cái 1 làm việc như thế nào
em lấy 1 range bằng lệnh này

rSelect phải là Range chứ (trong khi code của bạn thì rSelect lại là chuổi chứa giá trị địa chỉ cell)
Sửa vầy mới được

[COLOR=#ff0000]Dim rSelect As Range[/COLOR]
[COLOR=#ff0000][B]Set rSelect = Selection[/B][/COLOR]
If DocHyperlinkExists(rSelect) = False Then
  MsgBox ("not avaible")
Else
  MsgBox ("avaible")
End If

Mấy chổ màu đỏ là chổ đã sửa lại

 

[ruahiphop]

Bác nhiệt tình quá em chả biết làm gì ngoài thank bác hi vọng có bữa mời được bác đi uống nước
đây là đoạn code check tạm của em hình như nó đang bị lỗi nếu select range vào vùng ko có hyperlink
có cách nào check hyperlink collection nếu <> "" thì mới làm ko bác

Sub checkLink()
'
' checkLink Macro
'

Application.MacroOptions Macro:="checkLink", Description:="", ShortcutKey _
:="s"
Application.Goto Reference:="checkLink"
Dim rSelect As Range
Set rSelect = Selection
Dim iCount: iCount = 0
Dim arrAdd()
Dim n As Integer
Dim i As Range
Dim strAdress As String
Dim strName As String
For Each i In rSelect
If DocHyperlinkExists(i) = False Then
strAdress = i.Hyperlinks(1).SubAddress
strName = i.Value
If strAdress <> "" And strName <> "" Then
ReDim Preserve arrAdd(iCount)
arrAdd(iCount) = "HyperLinkname : " & strName & Space(4) & "Dead Address : " & strAdress
iCount = iCount + 1
End If
End If
Next

Dim strFileName As String
Dim sText As String
Dim iFileNum As Integer
strFileName = "C:\Users\xuanth5a\Desktop\DeadLink.txt"
iFileNum = FreeFile

Dim sizeArray: sizeArray = UBound(arrAdd)
Open strFileName For Output As iFileNum
Print #iFileNum, "************ Dead HyperLink Dead ************"
For iBegin = 0 To sizeArray
Print #iFileNum, arrAdd(iBegin)
Next
Close #iFileNum

End Sub
Function DocHyperlinkExists(ByVal rLink As Range) As Boolean
Dim cLink As Hyperlink, tmpAdd As String
On Error Resume Next
If rLink.Hyperlinks(1).SubAddress <> "" Then
tmpAdd = Range(rLink.Hyperlinks(1).SubAddress).Address
DocHyperlinkExists = tmpAdd <> ""
End If
End Function

Em Cám ơn Bác

 

[ndu96081631]

Bác nhiệt tình quá em chả biết làm gì ngoài thank bác hi vọng có bữa mời được bác đi uống nước
đây là đoạn code check tạm của em hình như nó đang bị lỗi nếu select range vào vùng ko có hyperlink
có cách nào check hyperlink collection nếu <> "" thì mới làm ko bác


Em Cám ơn Bác

Code sai nhiều quá
Viết lại cho bạn đây:

Sub checkLink()
  Dim hlnk As Hyperlink, sh As Worksheet, lCount As Long, iFileNum As Integer
  Dim arrAdd(), strAdress As String, strName As String, tmpFile As String
  Set sh = ActiveSheet
  If sh.Hyperlinks.Count Then
    ReDim arrAdd(1 To sh.Hyperlinks.Count)
    For Each hlnk In sh.Hyperlinks
      If DocHyperlinkExists(hlnk.Range) = False Then
        strAdress = hlnk.SubAddress
        strName = hlnk.Range.Value
        lCount = lCount + 1
        arrAdd(lCount) = "HyperLinkname : " & strName & Space(4) & "Dead Address : " & strAdress
      End If
    Next
    tmpFile = CreateObject("Shell.Application").Namespace(16).Self.Path & "\DeadLink.txt"
    If lCount Then ''<--- kiem tra xem có tìm dc DeadLink không?
      iFileNum = FreeFile
      Open tmpFile For Output As iFileNum
      Print #iFileNum, "************ Dead HyperLink Dead ************"
      For lCount = 1 To UBound(arrAdd)
        Print #iFileNum, arrAdd(lCount)
      Next
      Close #iFileNum
    End If
  End If
End Sub

Khỏi cần Select gì cả, cứ chạy code, nó sẽ tìm trong ActiveSheet, có link thì kiểm tra, không có thì thôi
Muốn duyệt hết tất cả các sheet cũng không có vấn đề ---> Thêm 1 vòng lập nữa
------------
Nói thêm: Bạn đặt biến strFileName = "C:\Users\xuanth5a\Desktop\DeadLink.txt" là không tổng quát... Mang file sang máy tính khác thì đường dẫn này chẳng tồn tại. Vậy để tổng quát thì phải dùng code lấy đường dẫn của Desktop như tôi làm ở trên

 

[ruahiphop]

Thank Bác nhiều
Nếu em muốn duyệt hết tất cả các sheets thì em phải chèn đoạn code vào đâu.
em thấy đoạn code trên bác đang viết cho activesheet
giả sử em muốn duyệt tất cả

For i = 1 To Application.Sheets.Count 
Set sh = ActiveSheet ' chỗ này em có cần thay bằng sheets(i)  để tổng quát hay không ạ
  If sh.Hyperlinks.Count Then
    ReDim arrAdd(1 To sh.Hyperlinks.Count) 
    For Each hlnk In sh.Hyperlinks
      If DocHyperlinkExists(hlnk.Range) = False Then
        strAdress = hlnk.SubAddress
        strName = hlnk.Range.Value
        lCount = lCount + 1
        arrAdd(lCount) = "HyperLinkname : " & strName & Space(4) & "Dead Address : " & strAdress
      End If
    Next
    tmpFile = CreateObject("Shell.Application").Namespace(16).Self.Path & "\DeadLink.txt"
    If lCount Then ''<--- kiem tra xem có tìm dc DeadLink không?
      iFileNum = FreeFile
      Open tmpFile For Output As iFileNum
      Print #iFileNum, "************ Dead HyperLink Dead ************"
      For lCount = 1 To UBound(arrAdd)
        Print #iFileNum, arrAdd(lCount)
      Next
      Close #iFileNum
    End If
  End If
Next

Ngoài ra chỗ này ReDim arrAdd(1 To sh.Hyperlinks.Count) em đang nghĩ mình có nên tạo
1 biến để Redim hay không
Dim Count = Count + sh.Hyperlinks.Count
ReDim arrAdd(1 To Count)
Để gia tăng mảng chứa các deadlink qua từng sheets.

Em cám ơn bác nhiều

p/s: Bác hiện đang ở đâu đấy

 

[ndu96081631]

Thank Bác nhiều
Nếu em muốn duyệt hết tất cả các sheets thì em phải chèn đoạn code vào đâu.
em thấy đoạn code trên bác đang viết cho activesheet
giả sử em muốn duyệt tất cả

For i = 1 To Application.Sheets.Count 
  Set sh = ActiveSheet ' chỗ này em có cần thay bằng sheets(i)  để tổng quát hay không ạ
  ......
Next

Vậy thì cứ thay vào xem, chẳng hạn Set sh = sheets(i) và thí nghiệm là biết liền

Ngoài ra chỗ này ReDim arrAdd(1 To sh.Hyperlinks.Count) em đang nghĩ mình có nên tạo
1 biến để Redim hay không
Dim Count = Count + sh.Hyperlinks.Count
ReDim arrAdd(1 To Count)
Để gia tăng mảng chứa các deadlink qua từng sheets.

Nếu duyệt qua các sheet thì không ReDim vậy được mà phải dùng ReDim Preserve (tức lCount tăng bao nhiêu thì mở rộng mang arrAdd bấy nhiêu)
Code như sau:

Sub checkLink()
  Dim hlnk As Hyperlink, sh As Worksheet, lCount As Long, iFileNum As Integer
  Dim arrAdd(), strAdress As String, strName As String, tmpFile As String, i As Long
  For i = 1 To Sheets.Count
    Set sh = Sheets(i)
    If sh.Hyperlinks.Count Then
      For Each hlnk In sh.Hyperlinks
        If DocHyperlinkExists(hlnk.Range) = False Then
          strAdress = hlnk.SubAddress
          strName = hlnk.Range.Value
          lCount = lCount + 1
          ReDim Preserve arrAdd(1 To lCount)
          arrAdd(lCount) = "HyperLinkname : " & strName & Space(4) & "Dead Address : " & strAdress
        End If
      Next
    End If
  Next
  If lCount Then
    tmpFile = CreateObject("Shell.Application").Namespace(16).Self.Path & "\DeadLink.txt"
    iFileNum = FreeFile
    Open tmpFile For Output As iFileNum
    Print #iFileNum, "************ Dead HyperLink Dead ************"
    For lCount = 1 To UBound(arrAdd)
      Print #iFileNum, arrAdd(lCount)
    Next
    Close #iFileNum
  End If
End Sub

 

[ruahiphop]

Em cám ơn Bác.
em đang chuyển qua làm chức năng 2
Bác cho em hỏi
Khi em làm cho riêng từng sheets như này or vài cách move cursor tương tự thì được

sheet1.Cell(1,1).Select

Nhưng khi em khái quát lên cho tất cả các sheets

Dim sht As Worksheets
For Each sht In Worksheets
sht.Cells(1,1).Select
Next

thì nó báo select out of Range , chỉ làm đc mỗi sheets đầu nến mình đang ở sheets đầu
Bác mách giúp em với
Em cám ơn Bác

 

[Hoàng Trọng Nghĩa]

Em cám ơn Bác.
em đang chuyển qua làm chức năng 2
Bác cho em hỏi
Khi em làm cho riêng từng sheets như này or vài cách move cursor tương tự thì được

sheet1.Cell(1,1).Select

Nhưng khi em khái quát lên cho tất cả các sheets

Dim sht As Worksheets
For Each sht In Worksheets
sht.Cells(1,1).Select
Next

thì nó báo select out of Range , chỉ làm đc mỗi sheets đầu nến mình đang ở sheets đầu
Bác mách giúp em với
Em cám ơn Bác

Theo nguyên tắc, với 1 ô, khối ô muốn Select thì trước hết Sheet chứa ô đó phải được Select, có nghĩa là Sheet đó phải Active. Vì vậy nếu bạn thao tác trên 1 sheet và sheet đó đang Active thì bạn muốn select vùng nào cũng được, nếu tác động select trên vùng của sheet khác, buộc bạn phải select sheet đó trước.

Tôi không biết bạn làm gì với thủ tục này (vì chẳng ai select nhiều vùng của nhiều sheet) nhưng để cho bạn hiểu thêm tôi sửa lại như sau:

Dim sht As Worksheets
For Each sht In Worksheets
sht.Select
sht.Cells(1,1).Select
Next

 

[ndu96081631]

Em cám ơn Bác.
em đang chuyển qua làm chức năng 2
Bác cho em hỏi
Khi em làm cho riêng từng sheets như này or vài cách move cursor tương tự thì được

sheet1.Cell(1,1).Select

Nhưng khi em khái quát lên cho tất cả các sheets

Dim sht As Worksheets
For Each sht In Worksheets
sht.Cells(1,1).Select
Next

thì nó báo select out of Range , chỉ làm đc mỗi sheets đầu nến mình đang ở sheets đầu
Bác mách giúp em với
Em cám ơn Bác

Sai 2 chổ:
1> Dim sht As Worksheets ---> Lý ra phải là Dim sht As Worksheet (không có chữ "s")
2> sht.Cells(1,1).Select ---> Cell chỉ được Select nếu Sheet chứa nó đang Active
Sửa lại

Dim sht As Worksheet
For Each sht In Worksheets
Application.Goto sht.Cells(1, 1)
Next

 

[ruahiphop]

Cám ơn 2 bác em đã làm được rồi.
em đã active nó trong vòng for và đưa được tất cả về ^^

 

[ndu96081631]

Cám ơn 2 bác em đã làm được rồi.
em đã active nó trong vòng for và đưa được tất cả về ^^

Bạn lưu ý rằng việc "nháy tới nhảy lui", Active cái này cái nọ chỉ tổ làm chậm quá trình tính toán mà thôi
Cứ vòng lập quét qua các sheet, "âm thầm" thu thập dữ liệu cũng đâu có vấn đề gì
Tôi chúa ghét kiểu code mà khi chạy nó "nhay lung tung" --> Chả được tích sự gì