• 締切済み

助けてください！VBAでのテキスト抽出方法について

どなたか助けていただけないでしょうか？ 以下の構文で、特定のHTTPタグの中身（テキスト）を抽出してます。 ですが、同じタブがあると以下の構文では一部しか抽出できません（マクロ実行時に最初に該当するタブの情報のみ）。 複数あるタブの全内容を抽出しExcelに出力したいのですがどのように記述すればよろしいでしょうか？ ※やりたいこと タブの内容をエクセルに出力 １つめのタブ Set rURLa = rURLa.Offset(1)　 へ出力 2つめのタブ Set rURLa = rURLa.Offset(2)　 へ出力 3つめのタブ Set rURLa = rURLa.Offset(3)　 へ出力 Private Sub CommandButton1_Click() Dim aURLa As String Dim l As Object Dim TL As Object Set rURLa = Range("B4") Do If rURLa = "" Then Exit Do Dim oIE As Object Set oIE = CreateObject("InternetExplorer.Application") oIE.Navigate rURLa Application.Wait [Now() + "0:00:10"] '10秒待つ While oIE.Busy Or oIE.ReadyState <> 4 DoEvents Wend For Each TL In oIE.Document.getElementsByTagName("div") 'spanタグを探す If TL.GetAttribute("class") = "title" Then 'class="title"なら rURLa.Offset(, 1) = TL.innerText Set rURLa = rURLa.Offset(1) End If Next oIE.Quit Set oIE = Nothing Loop MsgBox "リンク抽出完了" End Sub

みんなの回答

回答No.1

まず、選択カテゴリーが違います。エクセルでの操作を明記する事。 次に、HTTPタグとは何でしょうか？　HTTPプロトコルでのパケットのヘッダー部の事でしょうか？ さらに、できないのなら、貴方のやり方が間違っていると言う事です。別なやり方に変えましょう。 ロジックが間違っているということです。

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 【至急】VBAを使ったHTTPタグの取得方法

    どなたか助けていただけないでしょうか？ 以下の構文で、特定のHTTPタグの中身（テキスト）を抽出してます。 ですが、同じタブがあると以下の構文では一部しか抽出できません。 全てを抽出しExcelに出力したいのですがどのように記述すればよろしいでしょうか？ ※やりたいこと タブの内容をエクセルに出力 １つめ Set rURLa = rURLa.Offset(1)　 へ出力 2つめ Set rURLa = rURLa.Offset(2)　 へ出力 3つめ Set rURLa = rURLa.Offset(3)　 へ出力 Private Sub CommandButton1_Click() Dim aURLa As String Dim l As Object Dim TL As Object Set rURLa = Range("B4") Do If rURLa = "" Then Exit Do Dim oIE As Object Set oIE = CreateObject("InternetExplorer.Application") oIE.Navigate rURLa Application.Wait [Now() + "0:00:10"] '10秒待つ While oIE.Busy Or oIE.ReadyState <> 4 DoEvents Wend For Each TL In oIE.Document.getElementsByTagName("div") 'spanタグを探す If TL.GetAttribute("class") = "title" Then 'class="title"なら rURLa.Offset(, 1) = TL.innerText Set rURLa = rURLa.Offset(1) End If Next oIE.Quit Set oIE = Nothing Loop MsgBox "リンク抽出完了" End Sub

  • 画像抽出するVBAで画像を同じサイズにしたい

    サイトから画像を抽出する下記のVBAで、出力される結果について （１）画像の縦横比（サイズ）をすべて同じにしたい （２）（１）にあわせたセルのサイズにしたい （３）２列出力を３列出力にしたい のですが、どのようなソースに変更すればよいでしょうか？ 教えていただけると幸いです。 Sub hoge() 　　Dim oIE As Object 　　Dim e As Object 　　Dim i As Long 　　Dim j As Long 　　ActiveSheet.DrawingObjects.Delete 　　Rows.RowHeight = 140 　　Columns.ColumnWidth = 40 　　Set oIE = CreateObject("InternetExplorer.Application") 　　oIE.Visible = True 　　oIE.navigate "https://pro.foto.ne.jp/free/products_list.php/cPath/21_28_71" 　　Do While oIE.Busy Or oIE.ReadyState <> 4 　　　　DoEvents 　　Loop 　　Range("A1").Select 　　i = 1: j = 1 　　For Each e In oIE.Document.getElementsByTagName("img") 　　　　If LCase(e.nameProp) Like "*.jpg" _ 　　　　　　Or LCase(e.nameProp) Like "*.png" Then 　　　　　　Cells(i, j).Select 　　　　　　ActiveSheet.Pictures.Insert e.href 　　　　　　If j = 2 Then 　　　　　　　　i = i + 1 　　　　　　End If 　　　　　　If j = 1 Then 　　　　　　　　j = 2 　　　　　　Else 　　　　　　　　j = 1 　　　　　　End If 　　　　End If 　　Next 　　oIE.Quit End Sub

  • 【VBA】IEのCookieなどの削除方法

    こんにちわ。 Excel VBAで「自動でIEを起動してyahooを表示」するマクロを作成しています。 質問ですが、IEオブジェクトを作成したタイミングでCookieなどを削除するには、どのようにすればよろしいしょうか？ ※IEの[インターネットオプション] - [全般]タブ - [閲覧の履歴]にある削除（全削除）と同じ処理を実装したいです。 -------------------------------------------------- Dim oIe As Object Set oIe = CreateObject("InternetExplorer.Application") ' ★ここで削除したい oIe.Visible = True oIe.Navigate "http://www.yahoo.co.jp/" -------------------------------------------------- お忙しいところ大変申し訳ありませんが、ご教授をお願い致します。 以上です。 ++++++++++++++++++++ 【環境】 OS：WinXP 以上 ブラウザ：IE7 以上 Excel：Excel2007 以上 ++++++++++++++++++++

  • ＶＢＡを始めたばかりです。

    ＶＢＡを始めたばかりです。 下記でエラー「オブジェクトが必要です」が出ます。 何故ですか。 Sub A_Sample048() Dim mySht1 As Object Dim mySht2 As Worksheet '準備ここまで Set mySht1 = ActiveSheet If mySht1.Type = xlWorksheet Then Set mySht2 = mySht1 MsgBox mySht2.Name Else MsgBox "最前面のシートはワークシートではありません" End If Set mySht1 = Nothing 'オブジェクトの解放 Set mySht2 = Nothing End Sub よろしくお願いします。

  • エクセルVBA抽出がうまく出来ません

    エクセル2013VBA初心者です。 入力シートからＤＢシートへ、ＤＢシートから印刷シートへのデータ転記と印刷、入力内容のクリアまでは出来るようになりました。 ＤＢシートの検索を行い、記録内容を入力シートに転記する抽出を行いたいのですが、下記構文を書いたところで問題が発生しました。 If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then　 でとまります。メッセージは　‘Range’メソッドは失敗しました：‘Workshieet’オブジェクトというものです。 やろうとしていることは、入力シートに設けた“E12”と”G12”の二つの検索項目をキーにDBシートの行を特定し、この行の内容を入力シートに反映しようということです。 入力シートの検索項目“E12”、 ”G12”はそれぞれDBシートのA列、B列に格納されている項目で、年度と連番です。サンプルとして入力シート"C5"に抽出しようとしているDBシートD列は申請者名です。 恐れ入りますがよろしくご教示頂きたく、お願い申し上げます。 Sub DBシートから力情報を抽出する () Dim Sh1 As Worksheet Dim Sh2 As Worksheet Dim i As Long Dim j As Long Dim k As Long Set Sh1 = Worksheets("入力") Set Sh2 = Worksheets("DB") j = Sh1.Range("E12").Value k = Sh1.Range("G12").Value With Sh2 For i = 2 To .Range("A" & Rows.Count).End(xlUp).Row If Sh2.Range("A & i").Value = j And Sh2.Range("B & i").Value = k Then Sh1.Range("C5").Value = Sh2.Range("D & i").Value End If Next 　End With End Sub

  • VBAが止まります。

    皆さん、いつもありがとうございます。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 下から14行目の『 objMail.Attachments.Add asrs1』で止まってしまします。 asrs1をadrs1へ修正したりしましたが、改善されません。 昨日まで動いたいたのですが。 皆様、修正方法を教えていただけますでしdょうか。 ------------------------------------------------------- Sub メール作成() Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim wsMail As Worksheet Dim filead As String Dim tenp1 As String Dim tenp2 As String 'メール立ち上げ Set objOutlook = New Outlook.Application Set wsMail = ThisWorkbook.Sheets("リスト") '添付ファイルのアドレスを変数にする filead = Worksheets("リスト").Range("B3").Value '共通添付データのアドレスを読む tenp1 = filead & "\" & Worksheets("リスト").Range("B4") tenp2 = filead & "\" & Worksheets("リスト").Range("B5") Dim kobetsumail1 As String Dim kobetsumail2 As String Dim adrs1 As String Dim asrs2 As String '変数iを設定。最初は1 Dim i As Long i = 1 '送付前の確認メッセージ Dim rc As Long rc = MsgBox("記載に誤りが無いことを確認しましたか？", vbYesNo + vbQuestion, "確認") If rc = vbNo Then MsgBox "中断しました" End End If '基準となるセルを選択 Worksheets("リスト").Select Range("B7").Select '取引先名が書かれているB列が空欄になるまで続ける Do Until ActiveCell.Offset(i, 0).Value = "" '送付チェック欄が○なら作業を続ける If ActiveCell.Offset(i, 2).Value = "○" Then Set objMail = objOutlook.CreateItem(olMailTtem) '個別メールのデータ名称を読む Dim CC12(1) As String CC12(0) = ActiveCell.Offset(i, 6).Value CC12(1) = ActiveCell.Offset(i, 8).Value 'メールを作成する With wsMail objMail.to = ActiveCell.Offset(i, 4).Value objMail.CC = Join(CC12, ";") objMail.Subject = Range("B1").Value objMail.Bodyformat = olFormatPlain objMail.body = Range("B7").Offset(i, 0) & vbCrLf & Range("E7").Offset(i, 0) & "様" & vbCrLf & vbCrLf & Range("B2").Value & vbCrLf & vbCrLf kobetsumail1 = ActiveCell.Offset(i, 9).Value asrs1 = filead & "\" & kobetsumail1 kobetsumail2 = ActiveCell.Offset(i, 10).Value asrs2 = filead & "\" & kobetsumail2 If Range("B4").Value <> "" Then objMail.Attachments.Add tenp1 End If If Range("B5").Value <> "" Then objMail.Attachments.Add tenp2 End If If ActiveCell.Offset(i, 9).Value <> "" Then objMail.Attachments.Add asrs1 End If If ActiveCell.Offset(i, 10).Value <> "" Then objMail.Attachments.Add asrs2 End If objMail.Display objMail.Save End With End If i = i + 1 Loop Set objOutlook = Nothing MsgBox "下書きに保管しました" End Sub

  • エクセルでURLからタイトルのみを抽出する方法

    URLからタイトルを抽出するマクロについて教えて下さい。 忍者ブログの記事タイトルをURLから抽出しようとしたのですが 文字化けしてしまい全く分かりません。 他のサイトやブログだと普通に抽出出来るのですが・・・ 文字コード？か何かだと思うのですが、原因が分かりません。 ちなみに以下のマクロは、ネット上で検索して見つけたものを そのままコピーして使用しています。 －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ Public Sub ReadTitle() Dim url As Range Dim Http, buf As String Set Http = CreateObject("MSXML2.XMLHTTP") Set url = Range("A3") Do While (url.Value <> "") Http.Open "GET", url.Value, False Http.Send buf = StrConv(Http.ResponseBody, vbUnicode) 'msgbox buf url.Offset(0, 1).Value = getTitle(buf) Set url = url.Offset(1, 0) Loop Set Http = Nothing End Sub Private Function getTitle(buf As String) As String Dim pos1 As Long, pos2 As Long pos1 = InStr(1, buf, "<title>") If pos1 = 0 Then pos1 = InStr(1, buf, "<TITLE>") If pos1 = 0 Then getTitle = "" Exit Function Else pos2 = InStr(pos1 + 7, buf, "</TITLE>") End If Else pos2 = InStr(pos1 + 7, buf, "</title>") End If getTitle = Mid(buf, pos1 + 7, pos2 - pos1 - 7) End Function －－－－－－－－－－－－－－－－－－－－－－－－－－－－－－ 宜しくお願い致します。

  • VBAについて

    以下のプログラムは、1年間の価格合計を求めるプログラムです。 これを実行するとうまくいくこともありますが、エラーが起きることもあります。 どうやら下記コードが原因のようなのですが、間違いがわかりません。 Target.Offset(0, 1).Value = run * (13 - month) どこが間違っているのでしょうか。 また最終的に、A行かB行のどちらかが更新されたときにこのプログラムを 実行させたいのですが、方法がわかりません。 無知な質問ではありますが、どなたか教えてください。 --------------------------------------------------------- Private Sub Worksheet_Change(ByVal Target As Range) Dim month As Integer Dim run As Integer If Intersect(Target, Range("A25:A35")) Is Nothing Then Exit Sub Else If Target.Offset(0, -2).Value <> "" Then month = Target.Offset(0, -2).Value month = month - 3 If month = -2 Then month = 10 ElseIf month = -1 Then month = 11 ElseIf month = 0 Then month = 12 End If run = Target.Offset(0, 0).Value Target.Offset(0, 1).Value = run * (13 - month) End If End If End Sub

  • VBAでdim sh as worksheet

    にifで出た結果を抽出？したいのですがどうすればいいですか？ Dim ssh As Worksheet Set ssh = ThisWorkbook.Worksheets If ～ 　　　　　　　　　Thenの後にどうやればsshの中に入りますか？

  • VBAでのフォルダ指定方法について

    ＥＸＣＥＬファイルが保存されているディレクトリ配下のフォルダーを指定できるようにしたくていろいろ試してみたのですが、うまくいきません。 どなたか、お知恵をお貸しください。 以下ソースです。 Private Sub CommandButton1_Click() Dim ShellApp As Object Dim oFolder As Object Dim MyPath As String MyPath = ActiveWorkbook.Path Set ShellApp = CreateObject("Shell.Application") Set oFolder = ShellApp.BrowseForFolder(0, "処理ファイルの格納フォルダ選択", 1, MyPath) If Not oFolder Is Nothing Then TextBox1.Value = oFolder.Items.Item.Path End If Set ShellApp = Nothing Set oFolder = Nothing End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する