id:miku1973
ポイントあり100ptベストアンサーあり
コンピュータ

http://mik39.dousetsu.com/hatena_test.htm

今、このように白と黒の星が3つ並んだ表が、あるWebにあります。
パターンはこの4種類です。
（あくまでこれはサンプルで、実際の表は10行あります。4種類がランダムに10行並んでいます。）

これをExcelに10行分取得し、白の星は「☆」に、黒の星は「★」として変換したいです。

取得から☆、★の変換までVBAで実施できれば理想です。
やり方が思いつかないため質問いたします。

どうぞよろしくお願い致します。

回答の条件
  • 1人5回まで
  • 登録：
  • 終了：2012/12/01 13:05:03
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:Silvanus No.2

回答回数180ベストアンサー獲得回数71

ポイント50pt

エラー処理も施していない、芸の無いものですが。
Sheet1のセルA1からA2,A3と下方へ、URLのリストを入力していただくと
取得・変換結果が各シートに格納されます。

Option Explicit
Option Base 0

Sub Main()

Const strShtUrlList As String = "Sheet1"
Const strShtPrf As String = "Result"

Dim lngCntR As Long
Dim strURL As String
Dim strHTMLsrc As String

Sheets(strShtUrlList).Activate
    For lngCntR = 1 To Columns(1).SpecialCells(xlCellTypeLastCell).Row
        strURL = Cells(lngCntR, 1).Value
            If Left(strURL, 7) = "http://" Then
                strHTMLsrc = GetHTMLSource(strURL)
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = strShtPrf & Worksheets.Count
                Cells(1, 1).Value = strURL
                ConvStarChart strHTMLsrc
            End If
    Next

End Sub

Function GetHTMLSource(ByVal strURL As String) As String

Dim objXmlHttp As Object

Set objXmlHttp = CreateObject("MSXML2.XMLHTTP")

objXmlHttp.Open "GET", strURL, False
objXmlHttp.send (Null)

GetHTMLSource = objXmlHttp.ResponseText

Set objXmlHttp = Nothing

End Function

Sub ConvStarChart(ByVal strHTMLsrc As String)

Dim objRegExp As Object
Dim varMatch
Dim lngCntM As Long
Dim strStar(3) As String

strStar(1) = "☆☆☆"
strStar(2) = "★☆☆"
strStar(3) = "★★☆"
strStar(0) = "★★★"

Set objRegExp = CreateObject("VBScript.RegExp")

With objRegExp
    .IgnoreCase = True
    .Global = False
        Do
            .Pattern = "<td class=""col13Td"".*?>"
            Set varMatch = .Execute(strHTMLsrc)
                If varMatch.Count = 0 Then
                    Exit Do
                End If
                With varMatch(0)
                    strHTMLsrc = Mid(strHTMLsrc, .FirstIndex + .Length + 1)
                End With
            .Pattern = "</td>"
            Set varMatch = .Execute(strHTMLsrc)
                With varMatch(0)
                    Cells(lngCntM + 2, 1).Value = strStar(InStr(Left(strHTMLsrc, varMatch(0).FirstIndex), "<font color=""dcdcdc"">"))
                    strHTMLsrc = Mid(strHTMLsrc, .FirstIndex + .Length + 1)
                End With
            lngCntM = lngCntM + 1
        Loop
End With

End Sub

あれっ！？、データをExcelに読み込むものだと思っていたのですが
HTMLソースを置換することが目的なのですか！？
－－－
星の数がずれるミスは「Cells(lngCntM + 2, 1).Value =…」で
始まる行に誤りがありましたので訂正いたしました。

他8件のコメントを見る
id:Silvanus

メール拝領いたしました。暫くお待ち下さい。

2012/11/24 17:56:43
id:Silvanus

お返事お送りいたしました。動作確認宜しくお願いいたします。

2012/11/24 20:07:00

その他の回答（1件）

id:oil999 No.1

回答回数1728ベストアンサー獲得回数320

ポイント50pt

このマクロを試して下さい。
変換後のHTMLファイルはローカルディスクに保存します。
hogeConvの第1引数に変換対象のURLを、第2引数に変換後のフォルダ名＋ファイル名をセットしてください。

白い☆は、HTMLタグが

<font color="dcdcdc">★★★</font>

になっているかどうかで判断しています。
これ以外のHTMLタグの場合は認識できないので、お知らせ下さい。
★の数は任意個数に対応しています。

Option Explicit

'メインプログラム
Sub main()
    Call hogeConv("http://mik39.dousetsu.com/hatena_test.htm", "C:/test/test.html")
End Sub

'Web読み込み・変換処理
Sub hogeConv(url As String, outfname As String)
    'Web読み込み処理
    Dim oHttp As Object
    Dim str As String

    On Error Resume Next
        Set oHttp = CreateObject("MSXML2.XMLHTTP")
        If (Err.Number <> 0) Then
            Set oHttp = CreateObject("MSXML.XMLHTTPRequest")
        End If
    On Error GoTo 0
    If oHttp Is Nothing Then
        MsgBox "内部エラー", vbCritical
        Exit Sub
    End If
  
    With oHttp
        .Open "GET", url, False
        .Send
        str = StrConv(.responseBody, vbUnicode)     '文字コード変換
    End With
    Set oHttp = Nothing

    '変換処理
    Dim re, mc, m As Object
    Dim s2 As String
    
    Set re = CreateObject("VBScript.RegExp")
    re.Pattern = "<font color=""dcdcdc"">([★]+)</font>"    '検索パターン
    re.Global = True
    Set mc = re.Execute(str)
    For Each m In mc
        s2 = Replace(m.Value, "★", "☆")
        str = Replace(str, m.Value, s2)
    Next

    '書き出し
    Open outfname For Output As #1
    Print #1, str
    Close #1
End Sub
他1件のコメントを見る
id:oil999

会員制サイトは、IDとパスワードで認証していると思うので、回答のようなマクロでは読むことができないと思います。どのような認証方式を使っているのかお知らせいただければ、対応できるかもしれません。
それと回答にも書きましたが、☆印の出現パターン（HTMLタグのパターン）が一定していないと、検索・置換ができません。

2012/11/24 16:33:01
id:miku1973

会員制サイトなのですが、IDとPWを入力してログイン状態を保っているため、この状況下では私にとっては通常のWebと同じような状態になっているかなぁとは思います。

htmlの記述　→　Excelでの読み込み

＜font color="dcdcdc"＞★★★＜/font＞　→　☆☆☆
★＜font color="dcdcdc"＞★★＜/font＞　→　★☆☆
★★＜font color="dcdcdc"＞★＜/font＞　→　★★☆
★★★　→　★★★

こんな法則で変換できれば上手くいきそうです。（私にその技術はありませんが^^）

いろいろありがとうございます！

2012/11/24 16:44:43
id:Silvanus No.2

回答回数180ベストアンサー獲得回数71ここでベストアンサー

ポイント50pt

エラー処理も施していない、芸の無いものですが。
Sheet1のセルA1からA2,A3と下方へ、URLのリストを入力していただくと
取得・変換結果が各シートに格納されます。

Option Explicit
Option Base 0

Sub Main()

Const strShtUrlList As String = "Sheet1"
Const strShtPrf As String = "Result"

Dim lngCntR As Long
Dim strURL As String
Dim strHTMLsrc As String

Sheets(strShtUrlList).Activate
    For lngCntR = 1 To Columns(1).SpecialCells(xlCellTypeLastCell).Row
        strURL = Cells(lngCntR, 1).Value
            If Left(strURL, 7) = "http://" Then
                strHTMLsrc = GetHTMLSource(strURL)
                Worksheets.Add After:=Worksheets(Worksheets.Count)
                ActiveSheet.Name = strShtPrf & Worksheets.Count
                Cells(1, 1).Value = strURL
                ConvStarChart strHTMLsrc
            End If
    Next

End Sub

Function GetHTMLSource(ByVal strURL As String) As String

Dim objXmlHttp As Object

Set objXmlHttp = CreateObject("MSXML2.XMLHTTP")

objXmlHttp.Open "GET", strURL, False
objXmlHttp.send (Null)

GetHTMLSource = objXmlHttp.ResponseText

Set objXmlHttp = Nothing

End Function

Sub ConvStarChart(ByVal strHTMLsrc As String)

Dim objRegExp As Object
Dim varMatch
Dim lngCntM As Long
Dim strStar(3) As String

strStar(1) = "☆☆☆"
strStar(2) = "★☆☆"
strStar(3) = "★★☆"
strStar(0) = "★★★"

Set objRegExp = CreateObject("VBScript.RegExp")

With objRegExp
    .IgnoreCase = True
    .Global = False
        Do
            .Pattern = "<td class=""col13Td"".*?>"
            Set varMatch = .Execute(strHTMLsrc)
                If varMatch.Count = 0 Then
                    Exit Do
                End If
                With varMatch(0)
                    strHTMLsrc = Mid(strHTMLsrc, .FirstIndex + .Length + 1)
                End With
            .Pattern = "</td>"
            Set varMatch = .Execute(strHTMLsrc)
                With varMatch(0)
                    Cells(lngCntM + 2, 1).Value = strStar(InStr(Left(strHTMLsrc, varMatch(0).FirstIndex), "<font color=""dcdcdc"">"))
                    strHTMLsrc = Mid(strHTMLsrc, .FirstIndex + .Length + 1)
                End With
            lngCntM = lngCntM + 1
        Loop
End With

End Sub

あれっ！？、データをExcelに読み込むものだと思っていたのですが
HTMLソースを置換することが目的なのですか！？
－－－
星の数がずれるミスは「Cells(lngCntM + 2, 1).Value =…」で
始まる行に誤りがありましたので訂正いたしました。

他8件のコメントを見る
id:Silvanus

メール拝領いたしました。暫くお待ち下さい。

2012/11/24 17:56:43
id:Silvanus

お返事お送りいたしました。動作確認宜しくお願いいたします。

2012/11/24 20:07:00
id:miku1973

質問者から

yoshifuku2012/11/24 16:38:52

ありがとうございます！！

まだ試せていませんが、htmlファイルを書き換えることが目的ではなく、Excelに取り込んだ時☆と★で表現されることが目的です。

補足等ありましたらお願いします。報酬を少し増やしたいと思います。

規約違反として通知

コメント（0件)

コメントはまだありません

この質問への反応（ブックマークコメント）

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません
ユーザー登録をして使いはじめる!無料
すでに登録されている方はこちらからログイン
この質問に含まれるキーワード
知りたいことを検索してみよう
▲ページトップへ