忙しい現代人の腰&肩のお悩み対策!

こんにちわ、以前もここで質問させていただいたのですが、未完成なので再度質問させてください。
以前と違い、初日の部分を表を作りそこからとれるようにしました。

一、開催場所別にシートを分けているので、それぞれ会場のシートに12レース分表示したい(A1セル1レース目、E1セル2レース目...と順に横にずれてほしいです)。

一、開催場所でレースがない場合は、webサイト自体ない(エラーが起きる)のでwebサイトがないエラーが起きた時には、A1セルに本日のレースはありませんと表示したい

一、レース番号は引数取得ではなくループ処理にしたいのですが、For Lng_レース = 1 To 12これをどこに入れればいいか、わかりません。
--------------------------------------------------------------
以前、GooUserラックさんに作っていただいたVBAを自分なりに、模索しながらいじってみたのですが、どうしてもできませんでした。

Sub データ抽出(Day_日付 As Date, Lng_場 As Long, Lng_レース As Long)

Dim Str_アドレス As String
Dim Day_初日 As Date

Day_初日 = Day_日付 - Weekday(Day_日付, vbTuesday) + 1
Str_アドレス = "FINDER;http://app.boatrace.jp/race/01_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Sheets("作業").Select
Cells.Delete Shift:=xlUp
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Range("A1"))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
End Sub
--------------------------------------------------------------
を自分なりにアレンジしたデータ
--------------------------------------------------------------
Sub 桐生(Day_日付 As Date, Lng_場 As Long, Lng_初日 As Long)

Dim Str_アドレス As String

For Lng_レース = 1 To 12



Str_アドレス = "FINDER;http://app.boatrace.jp/race/" & Format(Lng_レース, "00")
Str_アドレス = Str_アドレス & "_" & Format(Lng_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Sheets("桐生").Select
Cells.Delete Shift:=xlUp
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Range("A1"))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
End Sub

回答よろしくお願いいたします。

「エクセルのwebクリエ、マクロ、VBAの」の質問画像

質問者からの補足コメント

このQ&Aに関連する最新のQ&A

A 回答 (4件)

呼び出し方はあっています。


URLにもう一か所レース場のコードを入れないといけなかったようです。
こちらに差し換えて下さい
----------------------------------------------------------------------------
Sub データ抽出(Day_初日 As Date, Day_日付 As Date, Lng_場 As Long)

Dim Obj_IE As Object
Dim Str_ソース As String
Dim Str_アドレス As String
Dim Lng_レース As Long

Lng_レース = 1
Str_アドレス = "http://app.boatrace.jp/race/" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"

Set Obj_IE = CreateObject("InternetExplorer.Application")
With Obj_IE
.Navigate Str_アドレス
Do While .Busy = True
DoEvents
Loop
Do While .Document.ReadyState <> "complete"
DoEvents
Loop
Str_ソース = .Document.Body.InnerText
.Quit
End With
Set Obj_IE = Nothing

If InStr(Str_ソース, "このページは表示できません") <> 0 Then
MsgBox ("アドレス違い")
Exit Sub
End If

If InStr(Str_ソース, "データが見つかりません") <> 0 Then
MsgBox ("データが見つかりません")
Exit Sub
End If

If Len(Str_ソース) < 1500 Then
MsgBox ("データが有りません")
Exit Sub
End If

Sheets("作業").Select
Cells.Delete Shift:=xlUp
For Lng_レース = 1 To 12
Str_アドレス = "http://app.boatrace.jp/race/" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Str_アドレス = "FINDER;" & Str_アドレス
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Cells(1, Lng_レース * 5 - 4))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
MsgBox ("終了しました")
End Sub
    • good
    • 0
この回答へのお礼

できましたーーー!!!!
ありがとうございます!!!

お礼日時:2016/06/03 15:22

図は良く見えないので、一例として


----------------------------------------------------------------------------
Sub 桐生()
Call データ抽出(#5/24/2016#, #5/29/2016#, 1)
End Sub
----------------------------------------------------------------------------
Sub データ抽出(Day_初日 As Date, Day_日付 As Date, Lng_場 As Long)

Dim Obj_IE As Object
Dim Str_ソース As String
Dim Str_アドレス As String
Dim Lng_レース As Long

Lng_レース = 1
Str_アドレス = "http://app.boatrace.jp/race/01_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"

Set Obj_IE = CreateObject("InternetExplorer.Application")
With Obj_IE
.Navigate Str_アドレス
Do While .Busy = True
DoEvents
Loop
Do While .Document.ReadyState <> "complete"
DoEvents
Loop
Str_ソース = .Document.Body.InnerText
.Quit
End With
Set Obj_IE = Nothing
If InStr(Str_ソース, "このページは表示できません") <> 0 Then
MsgBox ("アドレス違い")
Exit Sub
End If
If InStr(Str_ソース, "データが見つかりません") <> 0 Then
MsgBox ("データが見つかりません")
Exit Sub
End If
If Len(Str_ソース) < 1500 Then
MsgBox ("データが有りません")
Exit Sub
End If
Sheets("作業").Select
Cells.Delete Shift:=xlUp
For Lng_レース = 1 To 12
Str_アドレス = "http://app.boatrace.jp/race/01_" & Format(Day_初日, "yyyymmdd")
Str_アドレス = Str_アドレス & ".php?day=" & Format(Day_日付, "yyyymmdd")
Str_アドレス = Str_アドレス & "&jyo=" & Format(Lng_場, "00")
Str_アドレス = Str_アドレス & "&rno=" & Format(Lng_レース, "00") & "&type=program"
Str_アドレス = "FINDER;" & Str_アドレス
With ActiveSheet.QueryTables.Add(Connection:=Str_アドレス, Destination:=Cells(1, Lng_レース * 5 - 4))
.Name = "Data"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingAll
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Next
MsgBox ("終了しました")
End Sub
----------------------------------------------------------------------------
    • good
    • 0
この回答へのお礼

桐生は本日ないので、戸田で試してみたのですが、アドレス違いと出てくるのは何ででしょうか?

画像を更新したので見ていただけるとありがたいのですが、
Callで呼ぶ際に初日をC3セルから、日付をA3セルから、レース場所をB3セルから呼ぶようにしたいので
Call データ抽出(Range("C3").Value, Range("A3").Value, Range("B3").Value)
こうしたのですがあってますか?

画像見にくかったらもう一度上げます。

お礼日時:2016/06/03 14:30

開催日が4日間のものも有るんですか?


火曜日~日曜日開催として作ってしまっています。
①初日は必ず火曜日という訳ではないのですね?
②何か決まりがあるのでしょうか?
特に決まりが無いのならば、初日も入力しないとダメです。
    • good
    • 0
この回答へのお礼

はい、4日間しかないものもあったり、5、6日あったり、バラバラなのです。
なので1号艇という文字より上を削除などと指定できるのならばうれしいのですが、もし不可能ならあとで自分で調整してみますので、すべてのデータでも構いません。


>①初日は必ず火曜日という訳ではないのですね?

そうなんです,,,初日は本当に法則がなくバラバラなのです。
なので、
http://app.boatrace.jp/race/monthly/?day=20160603
このサイトの表をダウンロードして、画像でもわかる通りC列に初日を表示するようにしました!
なので(Day_日付 As Date, Lng_場 As Long, Lng_初日 As Long)のLng_初日 As Longを足せばいいかなと思ったのですが、うまくできませんでした。

お礼日時:2016/06/03 13:07

前回はとりあえず、インターネット上のデータをシートに張り付けるだけでした。


私は競艇をやらないので、この中でどのデータが欲しいのかが判りません。
1レースあたり4列のデータが張り付いています。1列くらいあけて次のレースを並べれば良いのでしょうか?
また「1号艇」より上は不要だと思いますし、「表の見方について」以下も不要だと思いますので削除してしまった方が良いのでしょうか?
    • good
    • 0
この回答へのお礼

ご回答ありがとうございます、いつもお世話になってます。

>1レースあたり4列のデータが張り付いています。1列くらいあけて次のレースを並べれば良いのでしょうか?

はい!1列あけていただいたら助かります!

>また「1号艇」より上は不要だと思いますし、「表の見方について」以下も不要だと思いますので削除してしまった方が良いのでしょうか?

不要です!
しかしここについてなのですが、1号艇より上は初日~最終日が全部で5日間のもあれば、4日間のもあり、その場合、行が変わってしまうのですが、「1号艇より上」を削除などと指定することは可能なのでしょうか?

お礼日時:2016/06/03 12:37

このQ&Aに関連する人気のQ&A

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人が検索しているワード

このQ&Aと関連する良く見られている質問

Qエクセル ある条件でセルの塗りつぶし。

エクセルを勉強中の初心者です。
あるセルに数値がある場合に、隣の空白セルを特定の色で塗りつぶしたい。

例えば黄色に塗りつぶした空白セルをコピーして他のセルに貼り付けると、貼り付けたセルは黄色になります。

やりたいことは、B2に数値がある場合にC2を塗りつぶしたいので、次のようにやってみました。

予め空白のE1を黄色にしておく。
C2に以下の式を入れましたが、黄色のE1を貼り付けることにはなりませんでした。
=IF(B2="","",E1)

関数式はあくまでも数値を扱うもので、根本的に間違っていたようです。

ある条件であるセルを塗りつぶすにはどうすればよろしいでしょうか?
よろしくお願いします。

Aベストアンサー

こんばんは!

数式によって「書式」は表示できませんので、
今回の質問の場合には「条件付き書式」を使います。

お使いのExcelのバージョンが判りませんが・・・

Excel2007以降の場合は
C2セルを選択 → ホーム → 条件付き書式 → 新しいルール → 「数式を使用して・・・」を選択 → 数式欄に
=B2<>""
という数式を入れ → 書式 → 「塗りつぶし」 → 好みの色(黄色)を選択しOK

Excel2003以前の場合
C2セルを選択 → メニュー → 書式 → 条件付き書式 → 「数式が」を選択 → 数式欄に
=B2<>""
とし → 書式 → パターン → 好みの色を選択しOK

これで大丈夫だと思います。m(_ _)m

QVBAを用いて、ウェブからデータを取り込みたい

エクセルVBAでウェブからデータを取り込みたいと思い、いろいろ挑戦していますが、以下のやり方(1)と(2)は失敗中です。
取り込みたいのは、ウェブページ中に描かれてある「表」の部分のデータです。
アドバイスをお願いいたします。

◆◆◆◆◆失敗(1)◆◆◆◆◆

ActiveSheet.QueryTables.Add(Connection:="url;http://***省略***.htm", Destination:=Range("A1"))

の方法の場合、取得したデータをエクセルシートに張り付けた場合に生じる文字化けがなおらず挫折・・・

QueryTableは文字コードを指定して読み込めないので困難という結論に至りました。

ちなみに目的のウェブページはshift-JISでcharsetされてますが、取得したいデータ部分はSQLサーバーでUTF-8で記述されていると思われます。

→http://oshiete.goo.ne.jp/qa/7864296.html


◆◆◆◆◆失敗(2)◆◆◆◆◆

ユーザーフォーム機能から、WEBブラウザーコントロールを用いて目的のウェブページを表示する方法では、表示したウェブページの情報をエクセルシートに転記する方法が分からず挫折・・・

url_report = "http://****省略.htm"
WebBrowser1.Navigate url_report 'ここから先、どうすればエクセルシートにデータ取得できる?


上記(1)や(2)以外で他のやり方も含め、経験者の方のアドバイスをお願いいたします。

ウェブページ中の表データをエクセルシートにVBAで自動取得したいのですが・・・何か良い方法がありますでしょうか? ((+_+))

エクセルVBAでウェブからデータを取り込みたいと思い、いろいろ挑戦していますが、以下のやり方(1)と(2)は失敗中です。
取り込みたいのは、ウェブページ中に描かれてある「表」の部分のデータです。
アドバイスをお願いいたします。

◆◆◆◆◆失敗(1)◆◆◆◆◆

ActiveSheet.QueryTables.Add(Connection:="url;http://***省略***.htm", Destination:=Range("A1"))

の方法の場合、取得したデータをエクセルシートに張り付けた場合に生じる文字化けがなおらず挫折・・・

QueryTableは文字コードを指定して読み込めない...続きを読む

Aベストアンサー

billborad-top100.net ブログのこの説明が参考になると思います。

http://billboardtop100.net/2011/03/excel-vba-ie-internet-explorer-table-copy-paste.html

つまり InternetExplorer.Application オブジェクトを使い、htmlテキストデータからtableに関するタグを見つけながら、セルに移していく操作です。

QエクセルでURL挿入後、名前を変える方法を教えて!

こんにちわ。
エクセルで作ったシートの中にURLを入れてから名前を変更したいです。
具体的にいうと妙高山のところにURLをいれても妙高山の表示がでる方法を教えてください。
どうやってもできません。わかる方教えてください。
お願いします。

Aベストアンサー

妙高山と書いてあるセルを右クリックして、「ハイパーリンク(H)」を選択

表示文字列を「妙高山」のままにして、アドレスの部分に任意のURLを貼り付けてOKをクリック

では駄目でしょうか?

QEXCELのセル上のURLをクリックしてもリンク先に飛ばない

よろしくお願いします。
質門の意味がわかりづらいタイトルかと思います。すみません。

具体的に(例示して)説明いたします。
例えば、EXCELのあるセルに、http://www.yahoo.co.jpと入力し、そのセルをクリックすると文字列の色が変わってマウスポインターが指(手のひら)マークになる。
それをクリックすればYahooジャパンのページにリンクする。それが普通だと思います。

ところが、数日前からそれができなくなってしまいました。
セルに入力(直接入力、またはメモ帳などからコピー)したURLをダブルクリックしても、何も変化しません。
当たり前かも知れませんが、URLがおかれたセルを右クリックしハイパーリンクの挿入から、
アドレス入力欄にそのURL(前述の例では、http://www.yahoo.co.jp)を入力すれば、文字列の色は青に変わり、クリックすれば飛びます。
また、そのセルのデータ(http://www.yahoo.co.jp)をデリート(デリートキーで)し別のURLを入力すると表示文字色は青に変わります。
しかし、そのセルをクリック(またはダブルクリック)してもマウスポインターの形は指マークに変わりません。当然リンクしません。

特別、システムあるいはEXCELの設定を変えたりしていませんので原因が分からず、不便を感じています。

対処方法ご存知の方、ご教示お願い致します。

よろしくお願いします。
質門の意味がわかりづらいタイトルかと思います。すみません。

具体的に(例示して)説明いたします。
例えば、EXCELのあるセルに、http://www.yahoo.co.jpと入力し、そのセルをクリックすると文字列の色が変わってマウスポインターが指(手のひら)マークになる。
それをクリックすればYahooジャパンのページにリンクする。それが普通だと思います。

ところが、数日前からそれができなくなってしまいました。
セルに入力(直接入力、またはメモ帳などからコピー)し...続きを読む

Aベストアンサー

Excelのバージョンが分かりませんが、
念のために設定を確認してみたら良いかもしれません。

Excel2003、2007
「Officeのハイパーリンク自動変換をオフにする - @IT」
http://www.atmarkit.co.jp/fwin2k/win2ktips/867hyperlink01/hyperlink01.html

Excel2007、2010、2013
「Excelでハイパーリンク機能を有効/無効に設定する方法」
https://121ware.com/qasearch/1007/app/servlet/qadoc?QID=016557

私は2007ですが、
「インターネットとネットワークのアドレスをハイパーリンクに変更する」のチェックは
デフォルト(初期設定)でオフでした。
すなわち、直接入力やテキストエディタからのコピーでは、
自動的にハイパーリンクになりませんでした。
ただ、もともとリンクのあるウェブページからセルにコピー&ペーストした場合は
自動的にハイパーリンクになりました。
ウェプページからコピーした場合でも、数式バーに入力した場合は、
自動的にハイパーリンクになりました。

とりあえず、設定を確認してみることをお勧めします。

Excelのバージョンが分かりませんが、
念のために設定を確認してみたら良いかもしれません。

Excel2003、2007
「Officeのハイパーリンク自動変換をオフにする - @IT」
http://www.atmarkit.co.jp/fwin2k/win2ktips/867hyperlink01/hyperlink01.html

Excel2007、2010、2013
「Excelでハイパーリンク機能を有効/無効に設定する方法」
https://121ware.com/qasearch/1007/app/servlet/qadoc?QID=016557

私は2007ですが、
「インターネットとネットワークのアドレスをハイパーリンクに変更する」のチ...続きを読む


人気Q&Aランキング