Excel (VBA)

Excel VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(指定なし : 指定なし)
IEからデータ取得
投稿日時: 20/09/21 19:47:00
投稿者: バチバッチ

初心者です
困っていることは、たまに取得データ
Range("B" & 14 + n).Value = AscEx(ie.document.getElementsByClassName("k-header-product__name-txt")(0).innerText)
の部分は空白でその下のは成功することがあります。
うまくいく場合もあるのですが、失敗することもあります。
 
以下説明
フォームのfrmNumberは商品コード入力フォームです。
サイトの特徴として、
『検索URL+商品コード』で、合致するときのみ、単商品の専用URLに時間差で飛びます。
存在しない場合は、そのままのURLです。
サイトにIEでログインしてから時間がたっていると、『再度ログイン画面』のURLに飛ぶようになっております。
サイトにはログインしていてもしてなくても取得データは変わらないので、『再度ログイン画面』になったら再度アクセスしてログアウト状態でデータ取得するようにしています。
サイトのURLは念のため隠しております。
 
ツールは
microsoft HTML Object Library
Microsoft WinTTP Services,version5.1
Microsoft Internet Controls
 
コードを短く端折ると自分でもわけがわからなくなりそうなのでほぼそのまま載せてます。
 
 
Sub sTWS()
    Dim sw As String 'サーチワード
    Dim tf As String: tf = "False" '成功かチェック ' False=失敗 True=成功 3=中断
    Dim cc As Long: cc = 0
 
    sw = frmNumber.doModal(1)
 
    Application.ScreenUpdating = False
 
    If Len(sw) <> 8 Then Exit Sub
     
    Unload frmNumber
 
 
     
    For cc = 0 To 2
     
        Call subWebScraping(sw, tf, cc)
        If tf = "True" Then Exit For '成功した為、終わる
        If tf = "3" Then Exit For '応答なしの為、終わる
         
    Next cc
    Application.ScreenUpdating = True
     
End Sub
Private Sub subWebScraping(sw As String, ByRef tf As String, cc As Long) 'URLが数秒後に代わる時の変更後のURL取得  合算
 
    Dim ie As New SHDocVw.InternetExplorer
    Dim cnt As Long: cnt = 0
    Dim tiCo As Long
    ie.Visible = False '空白IE起動
     
 
    ie.navigate "検索URL" & sw
  
    tiCo = Timer
     
 
     
    Call aaBusy(ie, tiCo, sw, tf)
    If tf = "3" Then Exit Sub
     
                 
    Dim objDOC As HTMLDocument '【重要】 ドキュメントの型 生成
    Set objDOC = ie.document '【重要】
     
    '指定したタグ、エレメントを集める
    Dim objELEs As IHTMLElementCollection 'DispHTMLElementCollection?
    Set objELEs = objDOC.getElementsByClassName("k-item-codes-item") '指定したタグを抜き出す
     
     
    If InStr(ie.LocationURL, "単商品URL") > 0 Then
                 
    End If
     
    '集めたタグ、エレメントに対して処理を行う
    Dim n As Integer 'カウンター
    Dim tt As String
     
    'データを張り付ける位置確認
    For n = 0 To 18
        If Range("B" & 14 + n).Value = "" And Range("B" & 15 + n).Value = "" Then
            On Error Resume Next
             
            Range("B" & 14 + n).Value = AscEx(ie.document.getElementsByClassName("k-header-product__name-txt")(0).innerText)
             
            tt = ie.document.getElementsByClassName("k-price-info__a-head")(0).innerText
            tt = Replace(tt, "取り除く何か1", "")
            tt = Replace(tt, "取り除く何か2", "")
 
            tt = Replace(tt, ") :", "")
            Range("F" & 15 + n).Value = tt
             
            Range("B" & 15 + n).Value = " " & objELEs.Item(1).innerText & " " & objELEs.Item(0).innerText
             
            Exit For
        End If
    Next
         
    ie.Quit 'IEを閉じる
    tf = "True" 'ここまで来たら成功?
     
    Exit Sub
     
End Sub
 
Sub aaBusy(ie As SHDocVw.InternetExplorer, tiCo As Long, sw As String, tf As String)
    Dim tt As String
    Dim cnt As Long
     
    For cnt = 0 To 3000
     
        Do While ie.Busy
            DoEvents
        Loop
         
        Do While ie.readyState < 4 '> READYSTATE_COMPLETE
            DoEvents
        Loop
 
        If Timer - tiCo > 8 Then '●s以上で諦める
            MsgBox sw & " のデータを取得できませんでした。"
            tf = "3" '中断の意味
            Exit Sub
        End If
         
        Debug.Print cnt & "●" & ie.LocationURL
         
        If InStr(ie.LocationURL, "検索URL") = 0 Then '検索画面のまま を含まないとき
            If InStr(ie.LocationURL, "再ログインURL") > 0 Then 'エラー画面の 時
                ie.Quit
                tf = "False"
                Exit Sub
            End If
        End If
         
        If InStr(ie.LocationURL, "単商品URL") > 0 Then
            Debug.Print "◎" & ie.LocationURL
            'MsgBox "発見"
            Exit For
        End If
         
        On Error Resume Next
        tt = ie.document.getElementsByClassName("k-price-info__a-head")(0).innerText
         
        If InStr(tt, "取り除く何か1") > 0 Or InStr(tt, "取り除く何か2") > 0 Then
            Exit For
        End If
 
    Next cnt 'ここまで更新待ち確認操作
 
End Sub
 
 
Function AscEx(strOrg As String) As String
 
  Dim strRet As String
  Dim intLoop As Integer
  Dim strChar As String
 
  strRet = ""
 
  For intLoop = 1 To Len(strOrg)
  
    strChar = Mid(strOrg, intLoop, 1)
    
    If (strChar >= "ァ" And strChar <= "ヶ") Then
      strRet = strRet & strChar
    Else
      strRet = strRet & StrConv(strChar, vbNarrow)
    End If
 
  Next intLoop
  
  AscEx = strRet
 
End Function

回答
投稿日時: 20/09/22 18:31:45
投稿者: simple

回答コメントがつきませんね。
 
以下は、希望を叶えてくれる話でなく、
黙っていられるよりましかというレベルのメモです。
 
>サイトのURLは念のため隠しております。
それは企業内のネット上のものであり、
開示してもそもそもアクセスはできないですよ、
ということなら、それはむしろ内部で協力を得ながら検証すべき事柄でしょう。
 
一般にアクセスできるものであれば、
どんな「念のため」なのか不明ですが、
それを示したほうが回答が寄せられる可能性は高まるでしょう。
 
あなたはサイトをよくご存じですが、こちらからはまったく内容が分かりません。
ご承知のとおり、ウエブサイトは個々で作りが違いますから、
個々事情の分析が必要で、一律に類推できるものではありません。
回答者がテスト実行して確認することもできないので、
何が起きているかを第三者が想像するのは至難の技でしょう。
喩えて言えば、他人が見た夢の話を聞かされているのと同じです。
そこで起きたということの理由を尋ねられても困るわけです。
 
正当な結果を返すこともある(というより通常は正しい)というなら、
コードの問題ではないのかもしれません。
検索データの問題だったり、サーバー側の問題かもしれません。
頻繁なWebスクレイピングに対して自衛手段をとり、
結果を返さないことも珍しくありません。
 
上手くいく時もあれば、そうでない時もあるということなら、
上手くいかない時に、その事実に基づいて原因を追求するしか手はないでしょう。
On Error Resume Next でエラーを隠蔽せずに、
エラーメッセージを出させて地道にデバッグするしかないでしょうね。

投稿日時: 20/09/22 19:57:36
投稿者: バチバッチ

simple様、回答ありがとうございます。
やはり通販サイトのURLがないと難しいのですね。
こちらにURLを含むコードを載せてみます。
返答いただけないとしてもエラーコードの処理等頑張ってみたいと思います。
 
 
変数swに入れるインプットボックスには半角で111‐1111 のような数字3文字ハイフン数字4文字
です
 
ツールは同じく
microsoft HTML Object Library
Microsoft WinTTP Services,version5.1
Microsoft Internet Controls
 
Sub sTWS()
    Dim sw As String 'サーチワード
    Dim tf As String: tf = "False" '成功かチェック ' False=失敗 True=成功 3=中断
    Dim cc As Long: cc = 0
 
    sw = InputBox("トラス●の注文コードを入力" & vbLf & "***-*** の形式で入力してください。", , "217-4559") '"217-4559"
 
    For cc = 0 To 2
 
        Call subTruscoWebScraping(sw, tf, cc)
        If tf = "True" Then Exit For '成功した為、終わる
        If tf = "3" Then Exit For '応答なしの為、終わる
         
    Next cc
    Application.ScreenUpdating = True
     
 
End Sub
Private Sub subTruscoWebScraping(sw As String, ByRef tf As String, cc As Long) 'URLが数秒後に代わる時の変更後のURL取得  合算
 
    Dim ie As New SHDocVw.InternetExplorer
    Dim cnt As Long: cnt = 0
    Dim tiCo As Long
    ie.Visible = False '空白IE起動
     
' If cc = 0 Then
' ie.navigate "https://www.orange-book.com/ja/f/view/applicationErrorScrOB.xhtml?messageId=E80504&overlay=false"
' ElseIf cc >= 1 Then
' ie.navigate "https://www.orange-book.com/ja/c/search/result.html?category=&q=" & sw
' End If
    '↓開いたIEにURL挿入
    ie.navigate "https://www.orange-book.com/ja/c/search/result.html?category=&q=" & sw
'商品専用ページ https://www.orange-book.com/ja/c/products/index.html?itemCd=BM820BLLL+++++++++++++++++++++7227
'時間経過エラー https://www.orange-book.com/ja/f/view/applicationErrorScrOB.xhtml?messageId=E80504&overlay=false
    
    tiCo = Timer
     
 
     
    Call aaBusy(ie, tiCo, sw, tf)
    If tf = "3" Then Exit Sub
     
                 
    Dim objDOC As HTMLDocument '【重要】 ドキュメントの型 生成
    Set objDOC = ie.document '【重要】
     
    '指定したタグ、エレメントを集める
    Dim objELEs As IHTMLElementCollection 'DispHTMLElementCollection?
    Set objELEs = objDOC.getElementsByClassName("k-item-codes-item") '指定したタグを抜き出す
     
     
    If InStr(ie.LocationURL, "products/index") > 0 Then
                 
    End If
     
    '集めたタグ、エレメントに対して処理を行う
    Dim n As Integer 'カウンター
    Dim tt As String
     
    'データを張り付ける位置確認
    For n = 0 To 18
        If Range("B" & 14 + n).Value = "" And Range("B" & 15 + n).Value = "" Then
            On Error Resume Next
             
            Range("B" & 14 + n).Value = AscEx(ie.document.getElementsByClassName("k-header-product__name-txt")(0).innerText)
             
            tt = ie.document.getElementsByClassName("k-price-info__a-head")(0).innerText
            tt = Replace(tt, "オレンジブック価格 (1", "")
            tt = Replace(tt, "貴社仕切価格 (1", "")
 
            tt = Replace(tt, ") :", "")
            Range("F" & 15 + n).Value = tt
             
            Range("B" & 15 + n).Value = " " & objELEs.Item(1).innerText & " " & objELEs.Item(0).innerText
             
            Exit For
        End If
    Next
         
    ie.Quit 'IEを閉じる
    tf = "True" 'ここまで来たら成功?
     
    Exit Sub
     
End Sub
 
Sub aaBusy(ie As SHDocVw.InternetExplorer, tiCo As Long, sw As String, tf As String)
    Dim tt As String
    Dim cnt As Long
     
    For cnt = 0 To 3000
     
        Do While ie.Busy
            DoEvents
        Loop
         
        Do While ie.readyState < 4 '> READYSTATE_COMPLETE
            DoEvents
        Loop
 
        If Timer - tiCo > 8 Then '●s以上で諦める
            MsgBox sw & " のデータを取得できませんでした。"
            tf = "3" '中断の意味
            Exit Sub
        End If
         
        Debug.Print cnt & "●" & ie.LocationURL
         
        If InStr(ie.LocationURL, "search/result") = 0 Then '検索画面のまま を含まないとき
            If InStr(ie.LocationURL, "applicationErrorScrOB") > 0 Then 'エラー画面の 時
                ie.Quit
                tf = "False"
                Exit Sub
            End If
        End If
         
        If InStr(ie.LocationURL, "products/index") > 0 Then
            Debug.Print "◎" & ie.LocationURL
            'MsgBox "発見"
            Exit For
        End If
         
        On Error Resume Next
        tt = ie.document.getElementsByClassName("k-price-info__a-head")(0).innerText
         
        If InStr(tt, "オレンジブック価格 (1") > 0 Or InStr(tt, "貴社仕切価格 (1") > 0 Then
            Exit For
        End If
 
    Next cnt 'ここまで更新待ち確認操作
 
End Sub
 
 
Function AscEx(strOrg As String) As String
 
  Dim strRet As String
  Dim intLoop As Integer
  Dim strChar As String
 
  strRet = ""
 
  For intLoop = 1 To Len(strOrg)
  
    strChar = Mid(strOrg, intLoop, 1)
    
    If (strChar >= "ァ" And strChar <= "ヶ") Then
      strRet = strRet & strChar
    Else
      strRet = strRet & StrConv(strChar, vbNarrow)
    End If
 
  Next intLoop
  
  AscEx = strRet
 
End Function

回答
投稿日時: 20/09/24 08:39:31
投稿者: simple

回答がつきませんね。
 
ピンポイントでの指摘はしませんが、
いずれにせよIEは、Excel側とは基本的に非同期で動作しますから、
サーバー側のレスポンスに起因したタイミングの問題のような気がします。
 
何か複雑なループになっていますが、
私だったら、以下のようなコードから出発しますね。
参照設定や、AscExプロシージャの利用は同じです。
参考になりますかね。
 

Option Explicit
Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Const url As String = "https://www.orange-book.com/ja/c/search/result.html?category=&q="

Sub main()
    Dim sw As String    'サーチワード
    Dim ie As SHDocVw.InternetExplorer
    Dim objDOC As HTMLDocument
    Dim objELEs As IHTMLElementCollection
    Dim n As Integer    '行番号
    Dim s1 As String
    Dim s2 As String

    sw = InputBox("トラス●の注文コードを入力" & vbLf & "***-*** の形式で入力", , "217-4559") 
    
    Set ie = New SHDocVw.InternetExplorer
    ie.Visible = True   'debug期間中は表示に

    '表示
    ie.navigate url & sw
    Do While ie.Busy Or ie.readyState <> READYSTATE_COMPLETE
        DoEvents
    Loop
    Sleep 500       ' 0.5秒の遊び期間

    'Debug.Print "●" & ie.LocationURL

    Set objDOC = ie.document
    Set objELEs = objDOC.getElementsByClassName("k-item-codes-item")
    'この処理の前後で、Do Loopや Sleepを使った時間待ちが必要かも知れません。

    If objELEs.Length > 0 Then
        n = Application.Max(13, Cells(Rows.count, "B").End(xlUp).Row) + 1

        '商品のタイトル
        s1 = objDOC.getElementsByClassName("k-header-product__name-txt")(0).innerText
        Range("B" & n).Value = AscEx(s1)

        '価格の単位
        s2 = objDOC.getElementsByClassName("k-price-info__a-head")(0).innerText
        s2 = Replace(s2, "オレンジブック価格 (1", "")
        s2 = Replace(s2, "貴社仕切価格 (1", "")
        s2 = Replace(s2, ") :", "")
        Range("F" & n + 1).Value = s2

        Do While ie.Busy Or ie.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop

        '品番コード、発注コード
        Range("B" & n + 1).Value = objELEs.Item(1).innerText & " " & objELEs.Item(0).innerText
    Else
        MsgBox "対象データなし"
    End If
    
    ie.Quit
End Sub

トピックに返信