0

多数のシートを含む Excel ブックがあります。各シートには、Web サイト上のさまざまなドキュメントへの 1 ～ 12 個のハイパーリンクがあります。これらのドキュメントは随時更新されます。すべてのハイパーリンクを新しいシートに一覧表示するだけでなく、各リンクの横にシート名も一覧表示するマクロが必要です。ハイパーリンクとセル参照をリストする次のものがあります

Sub CopyHyperLinks()  
  Dim rCell As Range 
  Dim ws As Worksheet 
  Dim Lhyper As Long                  
  On Error Resume Next 
  Application.DisplayAlerts = False 
  Sheets("Hypers").Delete 
  On Error Goto 0 
  Application.DisplayAlerts = True 
  Sheets.Add().Name = "Hypers" 

  For Each ws In Worksheets
    If ws.Name <> "Hypers" Then 
      For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count  
        ws.Hyperlinks(Lhyper).Range.Copy 
        With Sheets("Hypers").Cells(Rows.Count, 1).End(x1Up)  
          .Offset(1, 0).PasteSpecial
          .Offset(1, 1) = ws.Hyperlinks(Lhyper).Range.Address 
        End
        Application.CutCopyMode = False 
       Next Lhyper 
     End If 
  Next ws 
End Sub

これを変更して、セル参照の代わりにシート名を表示するにはどうすればよいですか。これらのハイパーリンクが有効な宛先であることを確認することもできますか?

4

1 に答える 1

4

次の行で、ハイパーリンクのワークシートの名前を取得できます。

ws.Hyperlinks(Lhyper)..Range.Worksheet.Name

これがあなたの作り直されたコードです（私が修正した他のいくつかの構文エラーが含まれていました）：

Sub CopyHyperLinks()
    Dim rCell As Range
    Dim ws As Worksheet
    Dim Lhyper As Long
    Dim rngLink As Range

    Application.DisplayAlerts = False

    On Error Resume Next
    Sheets("Hypers").Delete

    On Error GoTo 0
    Application.DisplayAlerts = True

    Sheets.Add().Name = "Hypers"

    For Each ws In Worksheets
        If ws.Name <> "Hypers" Then
            For Lhyper = 1 To ws.UsedRange.Hyperlinks.Count
                Set rngLink = ws.Hyperlinks(Lhyper).Range
                rngLink.Copy
                With Sheets("Hypers").Cells(Rows.Count, 1).End(xlUp)
                    .Offset(1, 0).PasteSpecial
                    .Offset(1, 1) = rngLink.Address
                    .Offset(1, 2) = rngLink.Worksheet.Name
                    .Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)
                End With
                Application.CutCopyMode = False
            Next Lhyper
        End If
    Next ws
End Sub

リンクを確認したい場合は、この回答のコードを含めてください。コードに次の行を含めます。

.Offset(1, 3) = CheckHyperlink(ws.Hyperlinks(Lhyper).Address)

また、このルーチン：

Public Function CheckHyperlink(ByVal strUrl As String) As Boolean

    Dim oHttp As New MSXML2.XMLHTTP30

    On Error GoTo ErrorHandler
    oHttp.Open "HEAD", strUrl, False
    oHttp.send

    If Not oHttp.Status = 200 Then CheckHyperlink = False Else CheckHyperlink = True

    Exit Function

ErrorHandler:
    CheckHyperlink = False
End Function

VBA プロジェクトに「Microsoft XML」ライブラリへの参照を含める必要があります。

于 2013-02-21T11:04:57.950 に答える