レッスン-投稿一覧パソコン仕事５倍塾ポータル

投稿/コメントを表示します。

エクセルマクロVBA「Web連携」

たかちゃんさんの投稿

(投稿ID: 4976)

いつもありがとうございます。お忙しい中、すみません。一つ質問させて下さい。

以下のような作りのWebページのTableタグから、各地域のデータを取得したいと考えています。
但し、北海道は、THタグの見出しとSPANタグの件名の両方が"北海道"となっているため、
If文でTHタグの内容が"北海道"の時は、Debug.printで書き出さないと設定したのですが
何故かIf文が適用されない状況です。

HTMLの中身
<TBODY>
<TR>
　<TH>北海道 </TH>
　<TD>北海道 </TD>
</TR>

<TR>
　<TH>東北 </TH>
　<TD>青森県秋田県...</TD>
</TR>

'以下に紹介するライブラリの参照設定をしてください
'Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため
'Microsoft HTML Object Library -> コンテンツのDOMを解析するため
'Microsoft Scrintping Runtime -> Dictionaryを使用するため
Sub GetArea()
    Dim url As String
    url = "https://www.sej.co.jp/products/area.html"

    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
    
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
    
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml As New MSHTML.HTMLDocument
    oHTml.body.innerHTML = xh.ResponseText 'htmlボディーをDOMとして取得
    
    Dim tr As MSHTML.HTMLHeadElement
    Dim spa As MSHTML.HTMLHeadElement
    Dim tiku As String
    
    For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
        'TRタグ内の0番目の子要素（THタグ）内のデータを取得
        '北海道はSpanタグ内にもあるため、ここでは北海道の時はDebug.printしないようIf文追加
        'なぜかIf文が適用されない状況です。
        If tiku <> "北海道" Then
            Debug.Print tiku
        End If
        
        'TRタグ内の１番目の子要素（TDタグ）内のSpanタグ内のデータを取得
        For Each spa In tr.ChildNodes(1).getElementsByTagName("span")
            Debug.Print spa.innerText
        Next
        
    Next
    
End Sub

2021/01/05 13:55

田中宏明さんのコメント

(コメントID: 7037)

たかちゃんさん:
> 何故かIf文が適用されない状況です。

余分な空白を取り除いてみたらどうなるでしょうか。

If LTrim(tiku) <> "北海道" Then
'If tiku <> "北海道" Then

2021/01/05 15:42

小川慶一さんのコメント

(コメントID: 7039)

お二人のやりとり、僕にとってもとても勉強になります。

文字列比較の件、たとえば、If文内を以下のようにしてみます。

If tiku <> "北海道" Then
    Debug.Print tiku
    If InStr(tiku, "北海道") Then
        Debug.Print Len("北海道"); Len(tiku); Len(tiku) = Len("北海道") '最後のは、文字列長さについて比較演算をして、true/falseを出力
    End If
End If

北海道ならまだしも、＃、♯、井のようなよく似た記号が混ざっていて判別できないこともあります
そういうときは、一文字ずつ比較します。
Asciiコードを出力するのも、違う記号かどうか人間が視覚的に判別しやすいので良いです。
以下は一例です。

Sub compare_strings_one_to_one()
    Dim target As String
    target = "北海道♯"
    Dim moji_from_website As String
    moji_from_website = "北海道＃"
    
    If Not Len(target) = Len(moji_from_website) Then
        Debug.Print "文字列の長さ異なります｡"; Len(target); Len(moji_from_website)
        Exit Sub
    End If
    
    Dim c As Long
    For c = 1 To Len(target)
        If Mid(target, c, 1) <> Mid(moji_from_website, c, 1) Then
            Debug.Print c & "文字目がおかしいです"
            Debug.Print Mid(target, c, 1) & vbTab & Asc(Mid(target, c, 1))
            Debug.Print Mid(moji_from_website, c, 1) & vbTab & Asc(Mid(moji_from_website, c, 1))
        End If
    Next
End Sub

以下は、出力結果:

4文字目がおかしいです
♯  -32270
＃  -32364

2021/01/05 17:08

小川慶一さんのコメント

(コメントID: 7040)

追記:
「丸」と「大きな丸」とか、ホント分からないです。「ＭＳゴシック」で見ると、比較すればわずかに大きさが違うと気づけるくらい。
機種依存文字や絵文字の丸も含めると、判別は本当に大変です。
これらを形で判別するのは至難の業。そういうとき、Asc関数は便利です。

Sub maru_iroiro()
    Const maru_normal As String = "○" '丸
    Const maru_grande As String = "◯" '大きな丸
    Debug.Print maru_normal; Asc(maru_normal)
    Debug.Print maru_grande; Asc(maru_grande)
End Sub

出力結果:

○-32357 
◯-32260

2021/01/05 17:17

たかちゃんさんのコメント

(コメントID: 7041)

小川先生、田中さん:

とても勉強になりました、ありがとうございます！
なんとか解決しました。(^^) ノーブレイクスペースが原因のようです。

何故かTRIM関数で、解決せず。。。１文字づつ確認すると、明らかに最後に半角スペースがあり文字数も１文字多い状況。
しかも、謎の半角スペースは、普通の半角スペースと文字コード（32）も同じでした。

ダメ元で、ノーブレイクスペース（文字コード：160）の対策を試した所TRIM関数で謎の半角スペースを除去できました。

参考ページ：
https://thom.hateblo.jp/entry/2016/09/20/150650

'以下に紹介するライブラリの参照設定をしてください
'Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため
'Microsoft HTML Object Library -> コンテンツのDOMを解析するため
'Microsoft Scrintping Runtime -> Dictionaryを使用するため
Sub GetArea()
    Dim url As String
    url = "https://www.sej.co.jp/products/area.html"

    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
    
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
    
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml As New MSHTML.HTMLDocument
    oHTml.body.innerHTML = xh.ResponseText 'htmlボディーをDOMとして取得
    
    Dim tr As MSHTML.HTMLHeadElement
    Dim spa As MSHTML.HTMLHeadElement
    Dim tiku As String
    Dim nazo As String
    Dim naz() As Byte
    Dim hankakuSP() As Byte
    Dim Ntiku As String
    
    For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
        
        nazo = Right(tiku, 1)
        
        Debug.Print nazo
        Debug.Print nazo = " "
        Debug.Print nazo = "　"
        Debug.Print Asc(nazo)

        'Byte型配列に入れて、謎のスペースの正体を調査
        naz = Right(tiku, 1)
        Debug.Print "謎の半角スペース"
        Debug.Print naz(0)
        Debug.Print naz(1)

        hankakuSP = " "
        Debug.Print "普通の半角スペース"
        Debug.Print hankakuSP(0)
        Debug.Print hankakuSP(1)


        'Byte型配列で調べた時に文字コード160ではなかったので
        'HTMLでよく利用される、NBSP(ノーブレークスペース)では
        'ないようでしたが、念の為、NBSPを普通の半角スペースに置き換えてから
        'Trimした所、スペースが除去できました。
        
        Ntiku = Trim(Replace(tiku, Chr(160), " "))
        
        If Ntiku = "北海道" Then
            Debug.Print "TRUE"
        Else
            Debug.Print "FALSE"
        End If
    Next
    
End Sub

2021/01/05 20:10

小川慶一さんのコメント

(コメントID: 7042)

たかちゃんさん、田中さん:

おもしろいです。

Byte配列にして解析する処理がなくても、Trimは効いていそうに思います。
この投稿下部に載せたコードは、検証用に書いたものです。どうでしょうか。(僕が、状況をちょっと理解しきれていない？)

あと、

https://thom.hateblo.jp/entry/2016/09/20/150650
↑
このページでさらに紹介されているteratailのサイト( https://teratail.com/questions/136057 )で、AscW関数、ChrW関数が紹介されています。
これらを使うと、Byte配列を使わないでもNBSP等の文字を調査をできそうです。(手元にサンプルがないので試せていませんが)

Sub GetArea()
    Dim url As String
    url = "https://www.sej.co.jp/products/area.html"
 
    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
     
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
     
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml As New MSHTML.HTMLDocument
    oHTml.body.innerHTML = xh.ResponseText 'htmlボディーをDOMとして取得
     
    Dim tr As MSHTML.HTMLHeadElement
    Dim spa As MSHTML.HTMLHeadElement
    Dim tiku As String
    For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
        inspect_string tiku
    Next
End Sub
Sub inspect_string(tiku As String)
    Dim nazo As String
    Dim naz() As Byte
    Dim hankakuSP() As Byte
    Dim Ntiku As String
    If Len(tiku) > Len(Trim(tiku)) Then
        Debug.Print "Trimに成功したので検査をスキップ"
        Exit Sub
    End If

    'この行以下は実行されない
    Debug.Print "Trimに成功しなかったので、以下でさらに検査" 
    Debug.Print tiku; Len(tiku)
    
    nazo = Right(tiku, 1)
     
    Debug.Print nazo
    Debug.Print nazo = " "
    Debug.Print nazo = "　"
    Debug.Print Asc(nazo)

    'Byte型配列に入れて、謎のスペースの正体を調査
    naz = Right(tiku, 1)
    Debug.Print "謎の半角スペース"
    Debug.Print naz(0)
    Debug.Print naz(1)

    hankakuSP = " "
    Debug.Print "普通の半角スペース"
    Debug.Print hankakuSP(0)
    Debug.Print hankakuSP(1)


    'Byte型配列で調べた時に文字コード160ではなかったので
    'HTMLでよく利用される、NBSP(ノーブレークスペース)では
    'ないようでしたが、念の為、NBSPを普通の半角スペースに置き換えてから
    'Trimした所、スペースが除去できました。
     
    Ntiku = Trim(Replace(tiku, Chr(160), " "))
     
    If Ntiku = "北海道" Then
        Debug.Print "TRUE"
    Else
        Debug.Print "FALSE"
    End If
End Sub

2021/01/06 01:24

たかちゃんさんのコメント

(コメントID: 7044)

小川先生、田中さん:

色々お騒がせしました。昨日は色々テストし過ぎてパニックになっていたようです。
改めて、テストをした所、何故昨日うまくいかなかったか理由がハッキリしました。

まず、北海道の後ろについていた謎の半角は、TRIM関数だけで除去できました。(^^;

問題は、If文にありました。
実は、北海道以外にも沖縄も同様に２回出力したくない為、IF文の条件にいれていました。
投稿する時は、簡潔にするため、沖縄の条件は省いて投稿していました。

自分の中では、北海道だけが条件のプログラムでもTrim関数でテストしたと思っていたのですが・・・。
昨日調査した際も、文字コードが32（普通の半角）でしたし、恐らくパニックになって以下のようなIF文でテストしていたのだと思います。

For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
       
        If Trim(tiku) <> "北海道" Or Trim(tiku) <> "沖縄" Then
            Debug.Print Trim(tiku)
        End If
         
        'TRタグ内の１番目の子要素（TDタグ）内のSpanタグ内のデータを取得
        For Each spa In tr.ChildNodes(1).getElementsByTagName("span")
            Debug.Print spa.innerText
        Next
         
    Next

イミディエイトウィンドウにはこの様に表示されます。
北海道
北海道
東北
.
.　
沖縄
沖縄県

For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
       
        If Trim(tiku) <> "北海道" And Trim(tiku) <> "沖縄" Then
            Debug.Print Trim(tiku)
        End If
         
        'TRタグ内の１番目の子要素（TDタグ）内のSpanタグ内のデータを取得
        For Each spa In tr.ChildNodes(1).getElementsByTagName("span")
            Debug.Print spa.innerText
        Next
         
    Next

イミディエイトウィンドウにはこの様に表示されます。
北海道
東北
.
.
鹿児島県
沖縄県

2021/01/06 08:40

小川慶一さんのコメント

(コメントID: 7046)

たかちゃんさん:

> 色々お騒がせしました。昨日は色々テストし過ぎてパニックになっていたようです。
> 改めて、テストをした所、何故昨日うまくいかなかったか理由がハッキリしました。

よくあることです v(^_^;

Webページの解析は、DPRで言うところの「RからR」ですので、なかなかすんなりとは行かないものがあります。

2021/01/06 09:07

たかちゃんさんのコメント

(コメントID: 7054)

Option Explicit

'以下に紹介するライブラリの参照設定をしてください
'Microsoft WinHTTP Services, version 5.1 -> HTTPリクエストをするため
'Microsoft HTML Object Library -> コンテンツのDOMを解析するため
'Microsoft Scrintping Runtime -> Dictionaryを使用するため
Dim dicTiku As New Dictionary
Dim dicNigi As New Dictionary
Dim ar As Variant

Public Sub Matome()
    GetArea
    GetOnigiri
    Dim i As Long
    Dim j As Long
    Dim k As Long
    
    For i = LBound(dicTiku.Keys) To UBound(dicTiku.Keys)
        Range("A1").Offset(i).Value = dicTiku.Keys(i)
        For j = LBound(dicNigi.Keys) To UBound(dicNigi.Keys)
            ar = dicNigi.Items(j) 'ar配列を使う前に、必ずこのようにしておくこと！
            If dicTiku.Keys(i) = dicNigi.Keys(j) Then
                For k = LBound(ar) To UBound(ar)
                    Range("B" & dicTiku.Items(i)).Offset(, k).Value = ar(k)
                Next
            End If
        Next
    Next

End Sub


Private Sub GetOnigiri()
    Dim url2 As String
    url2 = "https://www.sej.co.jp/products/a/cat/010010010000000/1/l100/"
    
    Dim xh2 As New WinHttp.WinHttpRequest
    xh2.Open "GET", url2, False
    xh2.send
     
    Dim sCode2 As String
    sCode2 = xh2.Status
    If sCode2 <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode2
    End If
     
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml2 As New MSHTML.HTMLDocument
    oHTml2.body.innerHTML = xh2.ResponseText 'htmlボディーをDOMとして取得

    Dim LInner As MSHTML.HTMLDivElement '<div class="list_inner～">
    Dim iTEm As MSHTML.HTMLDivElement '<div class="item_ttl">
    Dim iReg As MSHTML.HTMLDivElement '<div class="item_region">
    Dim tiiki As String
    Dim spTiiki As Variant
    Dim c As Long
   
    Dim oNigiri As String
    Dim yoko As Long
    yoko = 0
    For Each LInner In oHTml2.getElementsByClassName("list_inner")
        'おにぎり名
        For Each iTEm In LInner.getElementsByClassName("item_ttl")
            oNigiri = iTEm.innerText
            'おにぎり名をエクセルに書き出す
'            Range("B1").Offset(, yoko).Value = oNigiri
'            yoko = yoko + 1
        Next
        '販売地域
        '地域名をKey、おにぎり名をItemにしてDictionaryを作成
        For Each iReg In LInner.getElementsByClassName("item_region")
            tiiki = Mid(iReg.innerText, InStr(iReg.innerText, "：") + 1)
            spTiiki = Split(tiiki, "、")
            
            For c = LBound(spTiiki) To UBound(spTiiki)
                If Not dicNigi.Exists(spTiiki(c)) Then
                    dicNigi.Add spTiiki(c), Array(oNigiri)
                Else
                    ar = dicNigi.iTEm(spTiiki(c))
                    ReDim Preserve ar(UBound(ar) + 1)
                    ar(UBound(ar)) = oNigiri
                    dicNigi.iTEm(spTiiki(c)) = ar
                End If
            Next
            
        Next
        
    Next
    
End Sub


Private Sub GetArea()
    Dim url As String
    url = "https://www.sej.co.jp/products/area.html"
 
    Dim xh As New WinHttp.WinHttpRequest
    xh.Open "GET", url, False
    xh.send
     
    Dim sCode As String
    sCode = xh.Status
    If sCode <> 200 Then
        MsgBox "リクエストに失敗しました" & vbNewLine & sCode
    End If
     
    'htmlをDOMとして取得する。そのための変数を宣言。
    Dim oHTml As New MSHTML.HTMLDocument
    oHTml.body.innerHTML = xh.ResponseText 'htmlボディーをDOMとして取得
     
     
    '地域名を取得、dicTikuを作成。地域名(Key)、書き出し先の行(item)
    Dim tr As MSHTML.HTMLTableRow
    Dim spa As MSHTML.HTMLSpanElement
    Dim tiku As String
    Dim cnt As Long '地区を入力する行
    cnt = 1
     
    For Each tr In oHTml.getElementsByTagName("tbody")(0).getElementsByTagName("tr")
        tiku = tr.ChildNodes(0).innerText
        '北海道と沖縄は別の所にもある為、ここでは出力しない
        If Trim(tiku) <> "北海道" And Trim(tiku) <> "沖縄" Then
            Debug.Print Trim(tiku)
            
            dicTiku.Add Trim(tiku), cnt
            cnt = cnt + 1
        End If
         
        'TRタグ内の１番目の子要素（TDタグ）内のSpanタグ内のデータを取得
        For Each spa In tr.ChildNodes(1).getElementsByTagName("span")
            Debug.Print spa.innerText
            
            dicTiku.Add spa.innerText, cnt
            cnt = cnt + 1
        Next
         
    Next
    
    Dim lis As MSHTML.HTMLLIElement
    Dim Nlis As String
    
    For Each lis In oHTml.getElementById("pbBlock1155021").getElementsByTagName("li")
'            Debug.Print lis.innerText
            Nlis = Left(lis.innerText, InStr(lis.innerText, "：") - 1)
            '北陸は別の所にもある為、ここでは出力しない
            If Nlis <> "北陸" Then
                Debug.Print Nlis
                
                dicTiku.Add Nlis, cnt
                cnt = cnt + 1
            
            End If
    Next
     
End Sub

2021/01/07 11:33

たかちゃんさんのコメント

(コメントID: 7055)

以下の課題に挑戦し、成功しましたので記念に投稿します。
（添削は不要です。）

GetArea
地域名が羅列されたサイトからデータを取得
key->地域名 item->書き出し先の行

GetOnigiri
商品名と販売地域データを取得
Key->地域名 item->おにぎり名（Variant型配列に入れる）

２つのDictionaryから地域名をKeyに、指定の行へおにぎり名を書き出す。

早くパッと閃くレベルになりたいです。単純ですが、慣れていないので苦労しました。良い練習になりました。(^^;;

2021/01/07 11:35

小川慶一さんのコメント

(コメントID: 7053)

たかちゃんさん:

おはようございます。

ホント、すごいです。

実務に関係ない場でのトレーニングは、このくらいで本当に十分かと思います。
むしろ、実務でガンガンコードを書くことによりリソースを注いでください。

> 単純ですが、慣れていないので苦労しました。

Excel VBAでの辞書の活用は、構文的にちょっと面倒くさいんですよね。
僕の場合は、辞書を使ったコードの構想が湧いても、実装を思い浮かべようとしたところでゴチャゴチャしてきます。

> 早くパッと閃くレベルになりたいです。

そこは、もう、十分かと。
たかちゃんさんに提示いただいたコードに対しては、「ここまでの実装の要求をされたら酷だろうな」と考えて通常なら控えるであろうレベルの提案をしています。アルゴリズムについては、かなり鍛えられているのではないかと。

都度つど提示されるコードも、かなりのレベルで整理されていて、本当に素晴らしいです。
それどころか、いただいた投稿から僕が学んでいることも多いです。

「ほんの数ヶ月でここまで来られるとは...」と、社内のスタッフとも話しています。

引きつづき、良い学びと実践を！ (^^*

2021/01/07 19:01

田中宏明さんのコメント

(コメントID: 7056)

たかちゃんさん
もう追い越されそうです。
> ホント、すごいです。
>
> 実務に関係ない場でのトレーニングは、このくらいで本当に十分…

2021/01/08 02:49

たかちゃんさんのコメント

(コメントID: 7057)

小川慶一さん:

嬉しいお言葉、励みになります。本当にありがとうございます。
ガラパゴススタディのレッスンは、本当に凄いです。
動画編集とか多少地味めですが、内容が素晴らしい。こんなに分かりやすい講座は初めてです。
しかも、価格もお手頃。過去のコメントも大変勉強になりました。

また元生徒さんともコメント欄を通して交流できて、本当にラッキーでした。
MACの件で調べて頂いて、、。あの辺りからプログラミングに対する意識が変わっていき一気に
上達したように思います。（以前は、諦めが早すぎる所がありました。）

レッスンも残り僅かですが、今後は実務を意識して日々精進していきます。
> たかちゃんさん:
>
> おはようございます。

> 実務に関係ない場でのトレーニングは、このくらいで本当に十分かと思います。
> むしろ、実務でガンガンコードを書くことによりリソースを注いでください。

2021/01/08 09:33

たかちゃんさんのコメント

(コメントID: 7058)

田中宏明さん:

おはようございます。
田中さんのレベルって、私からしたら雲の上の神様のようです。(ﾟДﾟ )
本当になんとお礼をいったら、いつも本当にありがとうございます。
これからも宜しくお願いします！

> たかちゃんさん
> もう追い越されそうです。
> > ホント、すごいです。
> >
> > 実務に関係ない場でのトレーニングは、このくらいで本当に十分…

2021/01/08 09:42

田中宏明さんのコメント

(コメントID: 7059)

小川先生、たかちゃんさん:

私はガラパゴススタディのオンライン講座で会社人生に変化がありました。多分良い方に。

実はVBAでコードを仕上げるのも自動記録しかできない初学者並みに遅いですが、それなりに質が高いマクロを書けるようになりました。そのマクロが私の苦手とするスピーディーな実務処理を助け、更には他人の実務を手助けできる場面もあります。

最初の投稿はとてもドキドキしたものですが、投稿を繰り返しているうちに、他の受講生の質問に対してコメントすることもでき、また更に学びの機会を得ることができました。

引き続き、よろしくお願いします。

2021/01/08 14:24

小川慶一さんのコメント

(コメントID: 7063)

たかちゃんさん:

> ガラパゴススタディのレッスンは、本当に凄いです。
> 動画編集とか多少地味めですが、内容が素晴らしい。こんなに分かりやすい講座は初めてです。

こちらこそ、ありがとうございます。

もっとも、演習問題も2周、3周とくり返されていますし、丁寧に理解の足場を固めつつ学習を進められている印象ですし、成果は妥当なものと思います。

> 動画編集とか多少地味め

「DPR」の講座でもお伝えしていることですが、Dがしっかりしていれば(伝えたいことが、構造化されて整理されていれば)、Rはそれほど作り込まなくて良いと考えています。

2021/01/09 21:12

小川慶一さんのコメント

(コメントID: 7064)

田中宏明さん:

スキル情報からご経験から、いろいろシェアいただいていて、いつもありがたく思っています。

> 最初の投稿はとてもドキドキしたものですが、投稿を繰り返しているうちに、他の受講生の質問に対してコメントすることもでき、また更に学びの機会を得ることができました。

新システムのほうでは、こういう交流をもっとやりやすくなるようにしたいと思っています。

ひきつづき、よろしくお願いいたします。

2021/01/09 21:14