みんなの「教えて(疑問・質問)」にみんなで「答える」Q&Aコミュニティ

こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

縦に取得するのを横にする&最後に取得したところから

下記のマクロで、A1の語句をGoogle検索して、
上位5位のタイトル・URLをA2~A11へ記入できます。

そのA1に語句、A2~A11に上位5位というのを、
A1に語句、B1~K1に上位5位という風に変更したいです。


A1(語句)|A2(タイトル)|A3(URL)|



A1(語句)|B1(タイトル)|C1(URL)|

という感じです。


もう一つ、
途中でロボットでない証明のクリックがあります。
そのため、マクロを止めざるおえないです。

改めて、マクロを再開する時に、
最後に取得した語句から始めるようにしたいです。


これらは、どのようなマクロの記述になるでしょうか?

EXCEL2016です。
よろしくお願いいたします。



'//標準モジュール
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Dim objIE As SHDocVw.InternetExplorer '参照設定 Microsoft Internet Contorls
Dim oHTML As HTMLDocument '参照設定 Microsoft HTML Object Library
Sub Main()
 Dim c As Range
 Dim enSrTxt As String
 Dim counter As Long
 On Error GoTo ErrHandler
 Const BASEURL As String = "https://www.google.co.jp/search?q="
 With ActiveSheet
  Set objIE = Nothing
  For Each c In .Range("A1", .Cells(1, Columns.Count).End(xlToLeft))
   If c.Value <> "" Then
    If c.Value Like "*[ぁ-龠]*" Then
     enSrTxt = EnUtf8(c.Value)
    Else
     enSrTxt = c.Value
    End If
    Call getIE(BASEURL & enSrTxt)
    'Application.Wait TimeSerial(0, 0, 10) '遅くしていた元凶
    Sleep 500
    counter = counter + 1
   End If
  Next c
 End With
ErrHandler:
 If Err <> 0 Then
  MsgBox Err.Description
 End If
End Sub

Sub getIE(ByVal strURL As String)
 Dim cnt As Long
 Dim cl As Object
 Dim c As Range
 Dim nm As Long
 Set oHTML = New HTMLDocument
 If objIE Is Nothing Then
  Set objIE = New SHDocVw.InternetExplorer
 End If

 Set c = Cells(2, Columns.Count).End(xlToLeft) '二行目で計る
 If c.Value <> "" Then nm = c.Column + 1 Else nm = c.Column

 With objIE
  .Visible = True
  .navigate strURL
  Do While .Busy Or .readyState <> 4: DoEvents: Loop
  Set oHTML = .document
 End With

  Call outputLog(oHTML, nm)
  Set cl = objIE.document.getElementsByClassName("csb ch")
  cl(1).Click
  DoEvents
  Sleep 500
  Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop
  Set oHTML = objIE.document

 Cells(1, nm).EntireColumn.AutoFit
 Application.ScreenUpdating = True

End Sub
Sub outputLog(oHTML As HTMLDocument, nm As Long)
 Dim buf As Variant
 Dim j As Long, i As Long, k As Long
 Dim gLinks As Object
 Dim mTitle As Variant
 Dim cnt As Long
 j = Cells(Rows.Count, nm).End(xlUp).Row + 1

 With oHTML
  Set mTitle = oHTML.getElementsByClassName("LC20lb")
  Set gLinks = oHTML.getElementsByClassName("TbwUpd")
  If gLinks.Length > 0 Then
   If (gLinks.Length - 1) > 4 Then cnt = 4 Else cnt = gLinks.Length - 1
   For i = 0 To cnt '' 5コまで、
    Cells(j, nm).Value = mTitle(i).innerText
    buf = gLinks(i).ParentNode.href
    If InStr(1, buf, "%") > k Then buf = DecodeUTF8(buf)
    Cells(j + 1, nm).Value = buf
    Cells(j + 1, nm).Font.ColorIndex = 4 'フォントの色
    j = j + 2

    buf = ""
   Next
  End If
 End With
End Sub


Private Function EnUtf8(ByRef strSource As String) As String
 'Encode
 Dim objSC As Object
 Set objSC = CreateObject("ScriptControl")
 objSC.Language = "Jscript"
 EnUtf8 = objSC.CodeObject.encodeURIComponent(strSource)
 Set objSC = Nothing
End Function

Private Function DecodeUTF8(ByVal strSearch As String)
 'Decord
 If strSearch = "" Then Exit Function
 With CreateObject("ScriptControl")
  .Language = "JScript"
  With .CodeObject
   DecodeUTF8 = .decodeURI(strSearch)
  End With
 End With
End Function

投稿日時 - 2019-05-14 19:17:26

QNo.9616579

困ってます

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(1)

ANo.1

>途中でロボットでない証明のクリックがあります
これがよくわかりませんし、当方では再現できないので、
出力レイアウトの変更と
>改めて、マクロを再開する時に、
>最後に取得した語句から始めるようにしたいです。
の対応をしてみました。

Option Explicit

'//標準モジュール
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
  Dim objIE As SHDocVw.InternetExplorer '参照設定 Microsoft Internet Contorls
  Dim oHTML As HTMLDocument '参照設定 Microsoft HTML Object Library

'//----------------------
Sub Main()
 Dim enSrTxt As String
 Dim CntR As Long
 Dim counter As Long
 Const BASEURL As String = "https://www.google.co.jp/search?q="
 
 On Error GoTo ErrHandler
 With ActiveSheet
  Set objIE = Nothing
  counter = 0
  If .Cells(1, 2).Value <> "" Then
   CntR = .Cells(Rows.Count, 2).End(xlUp).Row + 1
  Else
   CntR = 1
  End If
  
  Do
   If .Cells(CntR, 1).Value = "" Then Exit Do
   If .Cells(CntR, 1).Value Like "*[ぁ-龠]*" Then
    enSrTxt = EnUtf8(.Cells(CntR, 1).Value)
   Else
    enSrTxt = .Cells(CntR, 1).Value
   End If
   Call getIE(BASEURL & enSrTxt, CntR)
   'Application.Wait TimeSerial(0, 0, 10) '遅くしていた元凶
   Sleep 500
   counter = counter + 1
   CntR = CntR + 1
  Loop
  '.Columns("A:K").EntireColumn.AutoFit
  'MsgBox Format(counter, "0") & "件完了"
 End With
 
ErrHandler:
 If Err <> 0 Then
  MsgBox Err.Description
 End If
End Sub

'//----------------------
Sub getIE(ByVal strURL As String, RowNum As Long)
 Dim cnt As Long
 Dim cl As Object
 Set oHTML = New HTMLDocument
 If objIE Is Nothing Then
  Set objIE = New SHDocVw.InternetExplorer
 End If

 With objIE
  .Visible = True
  .navigate strURL
  Do While .Busy Or .readyState <> 4: DoEvents: Loop
  Set oHTML = .document
 End With

 Call outputLog(oHTML, RowNum)
 Set cl = objIE.document.getElementsByClassName("csb ch")
 cl(1).Click
 DoEvents
 Sleep 500
 Do While objIE.Busy Or objIE.readyState <> 4: DoEvents: Loop
 Set oHTML = objIE.document

 Application.ScreenUpdating = True

End Sub

'//----------------------
Sub outputLog(oHTML As HTMLDocument, RowNum As Long)
 Dim buf As Variant
 Dim i As Long, k As Long
 Dim gLinks As Object
 Dim mTitle As Variant
 Dim cnt As Long

 With oHTML
  Set mTitle = oHTML.getElementsByClassName("LC20lb")
  Set gLinks = oHTML.getElementsByClassName("TbwUpd")
  If gLinks.Length > 0 Then
   If (gLinks.Length - 1) > 4 Then cnt = 4 Else cnt = gLinks.Length - 1
   For i = 0 To cnt '' 5コまで、
    ActiveSheet.Cells(RowNum, i * 2 + 2).Value = mTitle(i).innerText
    buf = gLinks(i).ParentNode.href
    If InStr(1, buf, "%") > k Then buf = DecodeUTF8(buf)
    ActiveSheet.Cells(RowNum, i * 2 + 3).Value = buf
    ActiveSheet.Cells(RowNum, i * 2 + 3).Font.ColorIndex = 4 'フォントの色
    buf = ""
   Next
  End If
 End With
End Sub

'//----------------------
Private Function EnUtf8(ByRef strSource As String) As String
 'Encode
 Dim objSC As Object
 Set objSC = CreateObject("ScriptControl")
 objSC.Language = "Jscript"
 EnUtf8 = objSC.CodeObject.encodeURIComponent(strSource)
 Set objSC = Nothing
End Function

'//----------------------
Private Function DecodeUTF8(ByVal strSearch As String)
 'Decord
 If strSearch = "" Then Exit Function
 With CreateObject("ScriptControl")
  .Language = "JScript"
  With .CodeObject
   DecodeUTF8 = .decodeURI(strSearch)
  End With
 End With
End Function

>途中でロボットでない証明のクリックがあります
画像を添付し、発生タイミングやサイクルなどを加え
質問を改めてもらえば識者からコメントを得られるかもしれません。

投稿日時 - 2019-05-15 09:17:44

あなたにオススメの質問