1

この VBA コードを変更することで、Excel のハイパーリンクから Web ページを読み取り、Web ページから読みやすさスコア、アンパサンド、および感嘆符を直接カウントすることは可能ですか? ファイルパスからも可能ですか？これはすべて 1 つのスプレッドシートにあります。

Option Compare Text

Sub Display_Stylometric_Scores()
    Dim Words As String
    Dim Characters As String
    Dim Paragraphs As String
    Dim Sentences As String
    Dim Sentences_per_paragraph As String
    Dim Words_per_sentence As String
    Dim Characters_per_word As String
    Dim Ratio_of_passive_sentences As String
    Dim Flesch_Reading_Ease_score As String
    Dim Flesch_Kincaid_Grade_Level_score As String
    Dim Coleman_Liau_Readability_Score As String
    Dim Ampersands As Long
    Dim Exclamations As Long
    Dim row As Integer
    Dim column As Integer
    Dim ActiveDocument As Object
    Dim RS As Object
    Dim txt As String

    row = 3

    Set ActiveDocument = CreateObject("Word.Document")

    Do While Worksheets("Sample_Output_2").Cells(row, 1) <> ""

        txt = Worksheets("Sample_Output_2").Cells(row, 2).Value
        ActiveDocument.Content = txt

        Set RS = ActiveDocument.Content.ReadabilityStatistics

        Words = RS(1).Value
        Characters = RS(2).Value
        Paragraphs = RS(3).Value
        Sentences = RS(4).Value
        Sentences_per_paragraph = RS(5).Value
        Words_per_sentence = RS(6).Value
        Characters_per_word = RS(7).Value
        Ratio_of_passive_sentences = RS(8).Value
        Flesch_Reading_Ease_score = RS(9).Value
        Flesch_Kincaid_Grade_Level_score = RS(10).Value
        Ampersands = CountChar(txt, "&")
        Exclamations = CountChar(txt, "!")

        Worksheets("Sample_Output_2").Cells(row, 4).Resize(1, 12).Value = 
            Array(Words, Characters, Paragraphs, Sentences, Sentences_per_paragraph, _               
                Words_per_sentence, Characters_per_word, Ratio_of_passive_sentences, _
                Flesch_Reading_Ease_score, Flesch_Kincaid_Grade_Level_score, _
                Ampersands, Exclamations)

        row = row + 1
    Loop

End Sub

Function CountChar(txt As String, char As String) As Long
    CountChar = Len(txt) - Len(Replace(txt, char, ""))
End Function
4

1 に答える 1

1

はい、MXSMLを使用してhttpリクエストを作成します。これが例であり、既存のコードの少しのリファクタリングです

Sub Main()

    Dim vaWrite As Variant
    Dim hDoc As MSHTML.HTMLDocument
    Dim xHttp As MSXML2.XMLHTTP

    'Set a reference to MSXML2
    'Open a webpage using GET
    Set xHttp = New MSXML2.XMLHTTP
    xHttp.Open "GET", "http://stackoverflow.com/questions/15103048/count-data-on-webpage-from-url-in-excel-vba"
    xHttp.send

    'Wait for the web page to finish loading
    Do Until xHttp.readyState = 4
        DoEvents
    Loop

    'If the web page rendered properly
    If xHttp.Status = 200 Then
        'Create a new HTMLdocument
        Set hDoc = New MSHTML.HTMLDocument
        'Put the GET response into the doc's body
        hDoc.body.innerHTML = xHttp.responseText

        'Get an array back containing the readability scores
        vaWrite = Display_Stylometric_Scores(hDoc.body.innerText)

        'Write that array to a worksheet
        Sheet1.Range("A2").Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
    End If

End Sub

Function Display_Stylometric_Scores(ByRef sText As String) As Variant

    Dim aReadStats(1 To 1, 1 To 12) As Double
    Dim wdDoc As Object
    Dim wdRs As Object
    Dim i As Long
    Dim vaSpecial As Variant

    Const lMAXIDX As Long = 10

    vaSpecial = Array("&", "!")

    Set wdDoc = CreateObject("Word.Document")
    wdDoc.Content = sText

    Set wdRs = wdDoc.Content.ReadabilityStatistics

    For i = 1 To lMAXIDX
        aReadStats(1, i) = wdRs(i).Value
    Next i

    For i = LBound(vaSpecial) To UBound(vaSpecial)
        aReadStats(1, lMAXIDX + 1 + i) = CountChar(sText, vaSpecial(i))
    Next i

    Display_Stylometric_Scores = aReadStats

End Function

Function CountChar(ByRef sText As String, ByVal sChar As String) As Long
    CountChar = Len(sText) - Len(Replace(sText, sChar, vbNullString))
End Function
于 2013-02-27T03:25:47.773 に答える