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

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

解決済みの質問

【VBA】このソースのどこを変更すれば良いの!?

Excelでマクロを使い、検索結果の一覧を取得したいと考えています。
検索した結果、こちらのサイトを見つけました。
-------------------------------------------------------------------
「WebクエリでGoogleの検索結果を取得する」
http://yumem.cocolog-nifty.com/excelvba/2012/03/webgoogle-c0f1.html
-------------------------------------------------------------------
問題なく動いたのですが、
URLの部分がホームページのタイトルではなく、
「キャッシュ」「類似ページ」と表示されます。
どの部分を、どの様に書き換えれば、HPのタイトルを表示されるようになるのでしょうか?

また可能であれば、URLとHPのタイトルを別にして表示させたいのですが、そちらも分かれば教えて下さい。

投稿日時 - 2018-01-19 20:20:17

QNo.9420082

すぐに回答ほしいです

質問者が選んだベストアンサー

このプログラム、まともに動きましたか?
実際の検索結果と比較してください。最初の数件が出力されません。
また、リンクも違う所をを指しています。
プログラムもひどいもので、少し直してどうにかなるレベルではありません。
新しく作った方が早いです。

これは、このままでは動きません。
設定で、他にも対応できるようにする為、こうしました。
次の様に入力してください。

B1 http://www.google.co.jp/search?q=
C1 excel vba
D1 &start=
B2 0
C2 99
D2 10
B3 検索結果
B4 *検索キーワード
A5 非出力
B5 #.*
C5 *このページを訳す*
D5 *動画検索結果*

見て想像できると思いますが、
C1は検索対象です。
C2は検索個数です。数を増やせばたくさん検索できます。
5行目は、出力したくないもののキーワードを指定します。「このページを訳す」「動画検索結果」を含むものは出力されません。
他の説明は、省略します。
中断した場合、 「Webクエリ」というシートが残ります。これがあったときは、削除して下さい。
'
Option Explicit
'
Sub Macro1()
'
  Dim SheetW As Worksheet
  Dim SheetO As Worksheet
  Dim Start As Integer
  Dim URL As String
  Dim NowCell As String
  Dim RowI As Integer
  Dim RowO As Integer
  Dim RowEnd As Integer
  Dim Col As Integer
  Dim ColEnd As Integer
'
  Set SheetO = ActiveSheet
  [A10:C10] = Array("番号", "URL", "説明")
  [A11:C1048576].Clear
  Set SheetW = Sheets.Add
  SheetW.Name = "Webクエリ"
  RowO = 11
  ColEnd = [A5].End(xlToRight).Column
'
  For Start = SheetO.[B2] To SheetO.[C2] Step SheetO.[D2]
DoEvents
    URL = SheetO.[B1] & SheetO.[C1] & SheetO.[D1] & Start
    With ActiveSheet.QueryTables.Add( _
      Connection:="URL;" & URL, _
      Destination:=[A1])
      .Name = "Google検索結果"
      .WebSelectionType = xlEntirePage
      .WebFormatting = xlWebFormattingAll
      .BackgroundQuery = False
      .Refresh
    End With
'
    With SheetO
    RowI = [A:A].Find(.[B3]).Row + 1
    RowEnd = Cells(Rows.Count, "A").End(xlUp).Row
    While Not Cells(RowI, "A") Like .[B4] And _
       RowI < RowEnd
      NowCell = Cells(RowI, 1)
'
      For Col = 2 To ColEnd
'
        If NowCell Like .Cells(5, Col) Then
          Exit For
        End If
      Next Col
'
      If Cells(RowI, 1).Hyperlinks.Count > 0 And Col > ColEnd Then
        .Cells(RowO, "A") = RowO - 10
        .Cells(RowO, "C") = NowCell
        NowCell = Cells(RowI, "A").Hyperlinks(1).Address
'        SheetO.Cells(RowO, "B") = NowCell
        .Hyperlinks.Add Anchor:=.Cells(RowO, "B"), _
          Address:=NowCell, _
          TextToDisplay:=NowCell
        RowO = RowO + 1
      End If
      RowI = RowI + 1
    Wend
    End With
  Next Start
' "Webクエリ"シート削除
  Application.DisplayAlerts = False
  SheetW.Delete
  Application.DisplayAlerts = True
End Sub

投稿日時 - 2018-01-20 16:43:30

補足

ありがとうございます!脱帽です。
もう1つ伺いたいのですが、このマクロを2、3回起動させると「1004」エラーが出てしまいます。
デバッグで確認すると「.Refresh」のところが黄色くなっています。
ここで問題があると言うことでしょうか?
解決方法はありますか?

投稿日時 - 2018-01-24 12:23:32

お礼

ご回答ありがとうございました!
補足の件は、相手方のサーバーに負荷が掛かりすぎた為と推測します。
再度、質問しなおしましたので、お時間があれば教えて頂きたく存じます。
https://okwave.jp/qa/q9421818.html

VBA本気で勉強しようと思います!
本当に、ありがとうございます!

投稿日時 - 2018-01-24 19:12:20

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

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

回答(2)

ExcelマクロでVBAやるんですね? で、他人のコード解読するのはプログラミングと同じ時間が掛かるし、ざーーーーーっと見、Googleスクリプトの説明だし。

コードサンプルや VBA講座 と言って、コードを実行させ、ウイルスに感染させるそうです。
なので、実行することはできませんし、コードをコピーするわけにも行きません。

HPのタイトル・・・って、どこのことですか?
って、質問氏のプロファイル読むと、初めての質問だし。

投稿日時 - 2018-01-20 06:36:57

お礼

ご回答ありがとうございます!
知りたいことを質問しただけです。

さて、お答えいただけるか、適切なご指導がないのであれば、ご回答ご遠慮下さい。

投稿日時 - 2018-01-20 10:16:01

あなたにオススメの質問