特定のワードでドメインが何番目のページにいるかを知りたいときに。
A列にドメイン名、B列にキーワードを入れて使う。
|
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 |
'参照設定 'Microsoft HTML Object Library 'Microsoft Internet Controls #If VBA7 Then Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr) #Else Private Declare Sub Sleep Lib "kernel32" (ByVal ms As Long) #End If Sub ieWait(obj As InternetExplorer) Do While obj.Busy = True Or obj.ReadyState <> 4 DoEvents Sleep 1000 Loop Do While obj.document.ReadyState <> "complete" DoEvents Sleep 1000 Loop Sleep Int((3000 - 1000 + 1) * Rnd + 1000) End Sub Sub auto_open() Application.CommandBars("cell").Reset With Application.CommandBars("cell").Controls.Add .OnAction = "main" .Caption = "KeyCheck" End With End Sub Sub auto_close() On Error Resume Next For i = 1 To 2 Application.CommandBars("cell").Controls("KeyCheck").Delete Next i End Sub Sub main() Dim ie As InternetExplorer Set ie = CreateObject("InternetExplorer.Application") With ie .Visible = True: .Top = 0: .Left = 0: .Width = 500: .Height = 500 End With c = 9 Do While Sheets("検索順位").Cells(1, c).Value <> "" c = c + 1 Loop Sheets("検索順位").Cells(1, c).Value = Month(Date) & "/" & Day(Date) r = 2 Do While Sheets("検索順位").Cells(r, 1).Value <> "" Call func(r, c, ie) r = r + 1 Loop ie.Quit Set ie = Nothing MsgBox "done" End Sub Sub func(r, c, ie As InternetExplorer) ie.navigate "http://www.yahoo.co.jp" Call ieWait(ie) ie.document.getElementById("srchtxt").Value = Sheets("検索順位").Cells(r, 2).Text ie.document.getElementById("srchbtn").Click Call ieWait(ie) If InStr(ie.document.body.innerText, Sheets("検索順位").Cells(r, 1).Text) <> 0 Then Sheets("検索順位").Cells(r, c) = 1 DoEvents Sleep Int((3000 - 1000 + 1) * Rnd + 1000) Exit Sub Else ie.navigate "JavaScript:scrollTo(0," & ie.document.body.ScrollHeight & ")" End If For pages = 2 To 10 For Each anchor In ie.document.all.tags("a") If Len(anchor.Text) <= 2 And Val(anchor.Text) = pages Then ie.navigate anchor.href Call ieWait(ie) If InStr(ie.document.body.innerText, Sheets("検索順位").Cells(r, 1).Text) <> 0 Then Sheets("検索順位").Cells(r, c) = pages DoEvents Sleep Int((3000 - 1000 + 1) * Rnd + 1000) Exit Sub Else ie.navigate "JavaScript:scrollTo(0," & ie.document.body.ScrollHeight & ")" End If Exit For End If Next anchor Next pages DoEvents Sleep Int((3000 - 1000 + 1) * Rnd + 1000) End Sub |