|
ラベルのチェック前
ラベルチェック後には、下画像のようにラベルはなくなっています。
 |
|
|
| シートコード |
|
下記のコードを入力してください。
'ラベルかどうかチェック
Private Function ExUrlLabelCheck(surl As String) As Boolean
Dim i As Integer
Dim nlen As Integer
Dim s As String
ExUrlLabelCheck = False
nlen = Len(surl)
For i = nlen To 0 Step -1
s = Mid$(surl, i, 1)
If s = "#" Then
ExUrlLabelCheck = True
Exit For
ElseIf s = "." Or s = "/" Then
Exit For
End If
Next
End Function
下記のコードに変更してください。
'リンクを取り出しセルに記入する
Private Function ExGetLinkLink(lrow As Long, lcol As Long) As Long
Dim i As Integer
Dim s1 As String
Dim coun As Long
coun = 0
For i = 0 To tIElink.document.Links.Length - 1
If Left(tIElink.document.Links(i).href, 4) = "http" Then
If ExUrlLabelCheck(tIElink.document.Links(i).href) = False Then
coun = coun + 1
End If
End If
Next
'リンク数分を行の挿入
Range(Cells(lrow + 1, lcol), Cells(lrow + coun, lcol)).Select
Selection.EntireRow.Insert
coun = 0
For i = 0 To tIElink.document.Links.Length - 1
If Left(tIElink.document.Links(i).href, 4) = "http" Then
If ExUrlLabelCheck(tIElink.document.Links(i).href) = False Then
'セルに記入
Cells(lrow + coun + 1, lcol) = tIElink.document.Links(i).href
coun = coun + 1
End If
End If
Next
ExGetLinkLink = coun
End Function
|
|
|
|
|
|
|
|