堺東のエステ サロン はインナーサーフェス.
堺東の筋膜リリースによる リラクゼーション マッサージサロン
ＥｘｃｅｌのＷｅｂクエリを利用して株価を取得するコードです。
Ｙａｈｏｏ！ファイナンスより
任意の企業を検索して
時系列タブから出力期間を表示後
URLを手動でコピー＆ペーストします。
複数ページを取得する際には、『１～２０件／ｘｘｘ件中』（ｘｘｘ ÷ ２０）を参考に
遷移させるページの数値を入力し
【データ取得】をクリックします。
実際の使用例イメージにつきましては
任天堂さんの２０１９年１月１日～２０２０年１２月３１日＜デイリー＞４８３件を参考にしていますので
下記ダウンロードいただければと思います。
※株価については、ご参考という形にて
お取り扱いにつきましては
各個人様の管理下、十分ご留意いただき
必要に応じて、別途多角的にご確認くださいませ。
数値の保証は致しておりません。
※プログラムを動作する際には
念のため、別途起動されているアプリケーション終了し
必要に応じて、バックアップを取得した後にお試しください。
ご利用のシステム環境によっては、作動しない場合がございます。
【動作環境：Windows10 & Office365】
Option Explicit
Sub WebQueryT()
Application.ScreenUpdating = False
Dim strURL As String
Dim i As Long
Dim MaxRow As Long
With Worksheets("top")
If .Range("B5") = "" Then
.Range("B5") = 1
End If
.Rows("10:1048576").Clear '既存データ消去
MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
strURL = "URL;" & .Range("B4")
For i = 1 To .Range("B5")
With .QueryTables.Add(strURL & "&p=" & i, .Range("A" & MaxRow))
.WebSelectionType = xlSpecifiedTables
If i = 1 Then
.WebTables = "1,2" '表1＆表2
Else
.WebTables = "2" '2Loop以降・・・表2のみ抽出
End If
'--------------------------------------------------
'xlEntirePage ページ全体
'xlAllTables すべてのテーブル
'xlSpecifiedTables 指定されたテーブル
.RefreshOnFileOpen = False 'ファイルを開く度、データ更新する際には「True」
'.Refresh 'プロパティで設定した内容を反映更新してデータを出力
.Refresh BackgroundQuery:=False '読み込み完了を待つ
End With
MaxRow = .Cells(Rows.Count, 1).End(xlUp).Row + 1
Next
Dim qt As QueryTable 'クエリテーブル削除
For Each qt In .QueryTables
qt.Delete
Next
.Range("D10").WrapText = False '前日比該当セル：文字の折り返し制御無し
.Rows("10:10").Interior.ColorIndex = 0 '背景色無し
.Columns("A:A").ColumnWidth = 23 '列幅調整
.Range("A12:G" & MaxRow - 1).WrapText = False '文字の折り返し制御無し
.Range("A12:G" & MaxRow - 1).MergeCells = False '並べ替えの為、結合解除
.Range("A12").AutoFilter 1, "日付" 'フィルター設定
.Range("A12").CurrentRegion. _
Offset(1, 0).Resize(.Rows.Count - 12).EntireRow.Delete '同項目削除
.ShowAllData
.Range("A12").CurrentRegion.Sort _
Key1:=Range("A12"), Order1:=xlAscending, _
Orientation:=xlTopToBottom, Header:=xlYes '昇順
Application.Goto .Range("A1"), True
ActiveWindow.FreezePanes = False
.Range("A13").Select
ActiveWindow.FreezePanes = True 'ウィンドウ枠固定
MsgBox ("終了")
End With
Application.ScreenUpdating = True
End Sub
Sub allClear()
Application.ScreenUpdating = False
With Worksheets("top")
.Rows("10:1048576").Clear
Application.Goto .Range("A1"), True
End With
ActiveWindow.FreezePanes = False
Application.ScreenUpdating = True
End Sub