Excel (VBA)

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

 
(Windows 10全般 : その他)
WEBスクレイピングについて
投稿日時: 21/11/29 20:43:01
投稿者: かいかい777

下記のコードについて質問です。
 
下記のコードはGoogle Googleを立ち上げ、新常磐交通のサイトにアクセスし、アクセスしたページで、B列にあるバス停名を検索し、
表示された検索結果のカタカナデータをC列に出力するものですが、検索結果は部分一致で表示されます。
 
部分一致で、複数の検索結果がある場合は常に最初のカタカナデータを取得してしまい、B列のバス停名とは違うカタカナデータを取得してしまいます。
 
B列と完全一致のカタカナデータを取得する方法はないでしょうか。
 
また、一連の処理をFOR文で繰り返していますが、これを配列処理する方法はありますか。
 
また、B列にあるバス停を新常磐交通で検索しても出てこない場合があります。その場合はC列に何も出力しないという処理をしたいのです。
 
試しに検索結果だけを配列に格納して、C列に一括出力したら、なぜか、直前のバス停のカタカナデータが出力されました。
 
ご教授をお願いします。
 
Sub テスト()
  
Dim i As Long
Dim V As String
Dim X As String
Dim LASTROW As Long
Dim vArray() As Variant
  
  
On Error Resume Next
  
  
LASTROW = Cells(Rows.Count, "B").End(xlUp).Row
  
     
  
a = "#busget .container_keyword .container_input input.keyword"
B = "#busget div.container_find input.btn_keyword"
C = "#busget .container_places li span.kana"
  
  
targetURL = ThisWorkbook.Worksheets("片仮名データ").Range("A2")
  
chromeDriver.Get targetURL
  
  
Application.ScreenUpdating = False
  
For i = 2 To LASTROW
  
  
searchKeyword = ThisWorkbook.Worksheets("片仮名データ").Cells(i, 2)
chromeDriver.FindElementByCss(a).SendKeys searchKeyword
chromeDriver.FindElementByCss(B).Click
Cells(i,"C")=chromeDriver.FindElementByCss(C).Text
chromeDriver.FindElementByCss(a).Clear
Next i
  
  
Application.ScreenUpdating = True
  
endTime = Timer
  
  
End Sub

回答
投稿日時: 21/11/29 22:33:24
投稿者: simple

https://hirachin.com/post-5019/
↑こちらのサイトに、CSSを使って要素指定する際の、
要素名の取得の仕方を含めて説明がありますから、
それを読んでトライしてみてください。
 
# ちなみに、URLくらい示すのが普通じゃないですか?
# それも回答者に調べさせるおつもりなんですか?

投稿日時: 21/11/29 22:59:56
投稿者: かいかい777

https://joko-bus.com/timetable/
 
補足します。URLは上記です。

回答
投稿日時: 21/11/30 09:18:14
投稿者: simple

すみませんが、変数をきちんと宣言してもらえませんか?
デバッグに近い質問であれば、実際に動かしたものをVBEからコピーペイストしてください。
それは簡単にするため省略しましたとか後で言われても、
それが無いために動作しない場合と見分けがつきませんので。
(モジュールの冒頭に Option Explicit を入れて、
  コンパイルエラーが出ないものを提示してください。)
 
また、On Error Resume Nextを不用意に挿入しないでください。
エラーはエラーとして表示して直していかないと、デバッグはできません。
「不都合なことは見ないことにする」という方針が、デバッグ上の障害になります。
その行をコメントアウトして(無効にしたうえで)、発生するエラーは解決したうえで、
再質問してもらえますか?(もちろん、要素取得できずにエラーになる部分は除きます)
 
できれば、インデントをきちんとつけて、コード部分を選択して[コード]をクリックして
投稿してください。
 
なお、ご希望のことに満額お答えできるものではないことを予めお断りしておきます。

回答
投稿日時: 21/11/30 15:32:05
投稿者: simple

できれば、

引用:
試しに検索結果だけを配列に格納して、C列に一括出力したら、なぜか、直前のバス停のカタカナデータが出力されました。
を再現できるコードを提示してください。

回答
投稿日時: 21/12/01 23:04:42
投稿者: simple

引用:
B列と完全一致のカタカナデータを取得する方法はないでしょうか。

先方の検索機能にそういうものが無い以上、部分一致のものを取り出して、
自前で、そのうちから完全一致を調べるしかありません。
引用:
また、一連の処理をFOR文で繰り返していますが、これを配列処理する方法はありますか。

そのFor文による繰り返しというのは、検索語の繰り返しのことですか?
そうであれば、当該サイトが一つずつしか検索語を受け付けないのですから、
検索語を繰り返し与えて、結果を受け取るしかないですよ。
 
配列処理の意味がわかりませんが、結果を配列に保持するという意味なら、下記です。
(1)動的に、縦2行、横n列の配列に書き込んでいき、最後にtransposeします。
   二次元目の方向にしか広げることができないためです。
(2)もしくは、最初から、少し大きめの、n行、2列の固定配列を用意し、
   それを、実際の個数分のセル範囲に書き込めば、使わなかった部分は捨てられます。
 
お願いしたコードの提示もありませんし、
こちらも不必要に時間を費やしたくないので、
とりえあえずのものを提示して、区切りとします。
 
Sub test()
    Dim i As Long
    Dim LASTROW As Long
    Dim A$, B$, C$   ' $ は As Stringと同じです。
    Dim targetURL$
    Dim searchKeyword$
    Dim e$
    Dim elms As WebElements
    Dim k As Long

    Dim chromeDriver As New Selenium.WebDriver
    chromeDriver.Start "chrome"
    
    A = "#busget .container_keyword .container_input input.keyword"
    B = "#busget div.container_find input.btn_keyword"
    C = "#busget .container_places li span.kana"

    targetURL = "https://joko-bus.com/timetable/"

    chromeDriver.Get targetURL

    LASTROW = Cells(Rows.Count, "B").End(xlUp).Row
    Columns("C").ClearContents

    Application.ScreenUpdating = False
    For i = 2 To LASTROW
        searchKeyword = Cells(i, "B").Value
        chromeDriver.FindElementByCss(A).SendKeys searchKeyword
        chromeDriver.FindElementByCss(B).Click

        Set elms = chromeDriver.FindElementsByCss("#busget .container_places li")
        If elms.Count = 0 Then
            Cells(i, "C") = "matchせず"                         ' ""でも可
        Else
            For k = 1 To elms.Count
                e = elms(k).FindElementByCss("a > span").Text                       '名称
                If e = searchKeyword Then
                    Cells(i, "C").Value = elms(k).FindElementByClass("kana").Text   'フリガナ
                    Exit For
                End If
            Next
            If Cells(i, "C") = "" Then Cells(i, "C") = "完全一致は無し"
        End If
        chromeDriver.FindElementByCss(A).Clear
    Next
    Application.ScreenUpdating = True
End Sub

なお、該サイトへのアクセスは1秒くらいの待ち時間を空けてください。
連続アクセスする場合には、サーバー側の負荷を高めない配慮も、たしなみのひとつです。

投稿日時: 21/12/04 21:51:16
投稿者: かいかい777

すみません、遅くなりました。
 
実際に起動したコードは以下です。
 
https://joko-bus.com/timetable/がA2に記載しているURLです。
  
Option Explicit
Dim chromeDriver As New Selenium.chromeDriver
Dim targetURL As String, searchKeyword As String
Dim HPurl As String
Dim a As String
Dim B As String
Dim C As String
  
  
Dim i As Long
Dim LASTROW As Long
  
  
On Error Resume Next
  
  
LASTROW = Cells(Rows.Count, "B").End(xlUp).Row
  
     
  
a = "#busget .container_keyword .container_input input.keyword"
B = "#busget div.container_find input.btn_keyword"
C = "#busget .container_places li span.kana"
  
  
targetURL = ThisWorkbook.Worksheets("片仮名データ").Range("A2")
  
chromeDriver.Get targetURL
  
  
Application.ScreenUpdating = False
  
For i = 2 To LASTROW
  
  
searchKeyword = ThisWorkbook.Worksheets("片仮名データ").Cells(i, 2)
chromeDriver.FindElementByCss(a).SendKeys searchKeyword
chromeDriver.FindElementByCss(B).Click
Cells(i, "C") = chromeDriver.FindElementByCss(C).Text
chromeDriver.FindElementByCss(a).Clear
Next i
  
  
Application.ScreenUpdating = True
  
 
  
  
End Sub
 

投稿日時: 21/12/04 21:55:45
投稿者: かいかい777

また、On Error Resume Nextは必要な処理です。
 
chromeDriver.Get targetURL で、GoogleChromeが起動されますが、サーバーのプロキシ認証を求められます。
 
そのプロキシ認証中に、chromeDriver.FindElementByCss(a).SendKeys searchKeyword の行に処理が進んでしまい、実行時エラー07が表示されます。
 
その実行時エラーが表示されないように、On Error Resume Nextを書いています。

投稿日時: 21/12/04 21:57:04
投稿者: かいかい777

simple さんの引用:
できれば、
引用:
試しに検索結果だけを配列に格納して、C列に一括出力したら、なぜか、直前のバス停のカタカナデータが出力されました。
を再現できるコードを提示してください。

 
すみません、そのコードを消してしまったので、今は提示ができません。

トピックに返信