VBAでWeb画面のテーブル要素がaタグになっているかを判定したい

vbaで特定のWebサイトのHTML要素のうち、テーブルタグに含まれる情報を取得したいと考えております。
基本的にはinnerTextでテキストの値を取得しているのですが、一部、アンカーになっている文字列に関しては
アンカーとなっていることを識別し、特別な処理を入れたい（文字列にマークを付けたい）と考えております。

innerTextで値を取得することまではできるのですが、どうしてもリンク状態の文字列を識別する方法がわからずでして、お知恵を拝借できませんでしょうか？

以下、コードの一部抜粋になります。

Set
1 
2'tableタグを一つずつを変数objにセット
3  For Each obj In ieDoc.getElementsByTagName("table")
4    
5   'trタグを一つずつを変数objにセット
6    For Each obj2 In obj.getElementsByTagName("tr")
7      j = j + 1
8      For Each obj3 In obj2.getElementsByTagName("td")
9        
10        Debug.Print obj3.innerHTML　　
11　　　　↑ここの情報にaタグになっている要素があります。
12　　　　 ここにaタグが含まれていた場合は、ExcelシートにinnerTextを記載する際に特別な処理を入れたいと考えております。
13        
14        i = i + 1
15        'タグのテキスト内容をセルにセット
16        Worksheets("Sheet1").Cells(j, i).Value = obj3.innerText
17 
18      Next
19    Next
20  Next
21コード

行動規範の内容に同意します

回答2件

解決されていますが、参考情報としてアップします。
(文字列は正規表現で編集)

読み込み対象html(名称:Test_Sample_Miniature.html)

<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN">
<META http-equiv="Content-Type" Content="text/html; charset=utf-8">
<head>
<title>Test_Sample_Miniature</title>
</head>
<body>

<table border="1">
　<tr>
　　<th>日付</th>
　　<th>集合場所<a>--000--</a></th>
　</tr>
　<tr>
　　<td>2010/1/1</td>
　　<td>東京<a>--AAA--</a></td>
　</tr>
　<tr>
　　<td>2016/4/8</td>
　　<td><a>--BBB--</a>渋谷</td>
　</tr>
　<tr>
　　<td>2016/5/20</td>
　　<td>原宿<a>--ccc--</a>駅</td>
　</tr>
</table>
</body>
</html>

読み込み側ExcelVBAソースプログラム
(参照設定:Microsoft VBScript Regular Expressions5.5必要)

Option Explicit
Sub Test_Sample_Miniature()

    Dim IE As InternetExplorerMedium
    Dim ieDoc As HTMLDocument
    Dim objs As IHTMLElementCollection
    Dim obj As IHTMLElement
    Dim j As Integer '行
    Dim i As Integer '列
    
    Set IE = New InternetExplorerMedium
    
    IE.Visible = True
    IE.Navigate ThisWorkbook.Path & "\" & "Test_Sample_Miniature.html"
    
    Do While IE.Busy Or IE.ReadyState < READYSTATE_COMPLETE
        DoEvents
    Loop
    Set ieDoc = IE.Document
    
    '----------------------------------------
    'table値を取得し正規表現にてaタグ値を取得
    '----------------------------------------
    Dim MyStr As String
    Dim reg As New RegExp
    Dim mclTR As MatchCollection
    Dim matTR As Match
    Dim mclTD As MatchCollection
    Dim matTD As Match
    Dim mclA As MatchCollection
    Dim matA As Match
    j = 0: i = 0
    '階層(1)table
    For Each obj In ieDoc.getElementsByTagName("table")
        '
        j = j + 1: i = 1
        Worksheets("Sheet1").Cells(j, i).Value = "( " & j & " - " & i & " )" & Replace(obj.innerText, vbCr, "")
        Worksheets("Sheet1").Cells(j, i).WrapText = False
        '
        reg.Pattern = "(<tr|<TR).[\s\S]*?(</tr>|</TR>)"
        reg.Global = True
        Set mclTR = reg.Execute(obj.innerHTML)
        '階層(2)tr
        For Each matTR In mclTR
            '
            j = j + 1: i = 2
            Worksheets("Sheet1").Cells(j, i).Value = "( " & j & " - " & i & " )" & Replace(matTR, vbCr, "")
            Worksheets("Sheet1").Cells(j, i).WrapText = False
            '
            reg.Pattern = "(<td|<TD).[\s\S]*?(</td>|</TD>)"
            reg.Global = True
            Set mclTD = reg.Execute(matTR)
            '階層(3)td
            For Each matTD In mclTD
                '
                j = j + 1: i = 3
                Worksheets("Sheet1").Cells(j, i).Value = "( " & j & " - " & i & " )" & Replace(matTD, vbCr, "")
                Worksheets("Sheet1").Cells(j, i).WrapText = False
                '
                reg.Pattern = "(<a|<A).[\s\S]*?(</a>|</A>)"
                reg.Global = True
                Set mclA = reg.Execute(matTD)
                '階層(4)a
                For Each matA In mclA
                    '
                    j = j + 1: i = 4
                    MyStr = Mid(matA, InStr(matA, ">") + 1, Len(matA) - Len("</a>") - InStr(matA, ">"))
                    Worksheets("Sheet1").Cells(j, i).Value = "( " & j & " - " & i & " )" & MyStr
                    Worksheets("Sheet1").Cells(j, i).WrapText = False
                    '
                Next
                '
             Next
            '
         Next
        '
    Next

End Sub

投稿2020/06/03 07:31

編集2020/06/03 15:32