Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


13 / 13307 ツリー ←次へ | 前へ→

【80851】web クエリの高速化 よし 19/6/1(土) 2:10 質問[未読]
【80854】Re:web クエリの高速化 γ 19/6/1(土) 9:29 発言[未読]
【80858】Re:web クエリの高速化 よし 19/6/1(土) 19:45 質問[未読]
【80861】Re:web クエリの高速化 γ 19/6/2(日) 20:31 回答[未読]
【80862】Re:web クエリの高速化 γ 19/6/2(日) 21:14 発言[未読]
【80865】Re:web クエリの高速化 よし 19/6/3(月) 3:16 お礼[未読]
【80864】Re:web クエリの高速化 γ 19/6/2(日) 22:42 発言[未読]

【80851】web クエリの高速化
質問  よし  - 19/6/1(土) 2:10 -

引用なし
パスワード
   VBA初心者です。
現在、全国保険者情報一覧というウェブページから保険者種別ごとにマクロ1でクエリデータをシートに貼り付け、マクロ2でマクロ1で貼り付けたデータの保険者番号を元に詳細情報ウェブページにアクセスし、を貼付シートを作成しそこに一時的貼り付け、必要箇所をコピして保険者番号の横にペーストしたら、今度はその下の保険者番号を元に詳細情報ウェブページにアクセスし、先ほどの貼付シートに上書きし、必要箇所をコピして保険者番号番号の横にペーストするというループマクロを組んだのですが、マクロ1はそれなりにすぐにおわりますが、マクロ2は保険者種別にもよりますが、件数が多いもので3000ぐらいあり、処理が終わるのに2時間ほどかかります。

このwebクエリマクロを早くする方法をご教授いただけないでしょうか。

実際に使用しているマクロは下記のとおりです。
注釈:URLは保険者番号を変えるだけでそれぞれの詳細情報ウェブページにアクセスできることから、セルに保険者番号のぞくURL入力し、そのセルを元にURLを組み合わせてアクセスしています。


Sub 詳細情報取込み介護保険除く()

'確認ボタン
Dim rc As Integer
rc = MsgBox("この作業は数時間を要します。(途中で止めることもできません)実行しますか?", vbYesNo + vbQuestion, "確認")
If rc = vbYes Then
  MsgBox "処理を行います。「終わりました」と表示されるまで触らないで下さい"

'高速化
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

'シート名の取得(SNはSheetNameの略)
  Dim SN As String
  SN = ActiveSheet.Name
  
'繰り返し準備(HNは保険者HokenjaNumberの略また回数の定義としても使用)
HN = 2
Do Until Cells(HN, 1) = ""
  
'URL取得(KURLはKobetsuURLの略)
  Dim KURL As String
  KURL = "URL;" & Sheets("保険者一覧").Cells(2, 3) & Sheets(SN).Cells(HN, 1) & Sheets("保険者一覧").Cells(2, 4)

'データ取り込み
  Sheets("貼付シート").Activate
  Application.CutCopyMode = False
  With ActiveSheet.QueryTables.Add(Connection:= _
    KURL, Destination:=Range( _
    "$A$1"))
    .Name = "dt01010016"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = False
    .RefreshStyle = xlOverwriteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlEntirePage
    .WebFormatting = xlWebFormattingNone
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
    .Delete
  End With
  
  '詳細情報の転記
  Sheets(SN).Cells(HN, 4) = Sheets("貼付シート").Range("A10")
  Sheets(SN).Cells(HN, 5) = Sheets("貼付シート").Range("A12")
  Sheets(SN).Cells(HN, 6) = Sheets("貼付シート").Range("A14")
  Sheets(SN).Activate
  
   '項目作成
   Range("D1") = "郵便番号"
   Range("E1") = "住所"
   Range("F1") = "電話番号"
  
  '回数増やす
  HN = HN + 1
Loop

'確認ダイアログ表示
Application.DisplayAlerts = True

'高速化停止
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

MsgBox "終わりました。"

Else
  MsgBox "処理を中断します。"
  
End If


End Sub

【80854】Re:web クエリの高速化
発言  γ  - 19/6/1(土) 9:29 -

引用なし
パスワード
   提示されたマクロとマクロ1マクロ2の関係がよくわかりませんが、
3000個の繰り返しを2時間と言うことは、一件2.4秒ですか。

ネットの状況、サーバー側のレスポンス等の状況に依存しますが、
その程度はかかるのかもしれませんよ。

Webクエリ自体はパッケージ化されたものなので、
ユーザー側で手を加えて高速化するとか言ったことはできません。

シート間の転記も3項目だけなら、そこが足を引っ張ることも
考えにくいでしょう。

【80858】Re:web クエリの高速化
質問  よし  - 19/6/1(土) 19:45 -

引用なし
パスワード
   >γ さん
マクロ1というのが、ウェブクエリにて新たなシートを作成し、抽出したデータ貼り付けるマクロです。
マクロ2はマクロ1で作成したシートのデータから詳細ページのURLを作成し、作成したURLを元にウェブクエリにて詳細ページのデータを抽出し、あらかじめ作成している貼付シートに上書きを行い、さらに貼付シートのデータをマクロ1で作成したシートに入力するマクロです。
うまく説明ができず申し訳ないです。

件数も多く、ウェブページにアクセスする回数も多いとこれだけ掛からず負えないのですかね。

ウェブクエリは高速化できないんですね。
自作でウェブクエリと同等のことができ、さらに高速化できるマクロは作成可能でしょうか?可能であればご教示頂けないでしょうか?厚かましいことをお願いしてごめんなさい。

【80861】Re:web クエリの高速化
回答  γ  - 19/6/2(日) 20:31 -

引用なし
パスワード
   動作するものを一応作って見ました。

<<結果シート>>のレイアウト
  A列  B列    C列     D     E   F
1 コード 保険者番号 保険者名  郵便番号  住所  電話番号
2
3

・予め設定されているA列の保険者用のコードを読み込んで使用します。
・B列以下の列に、サーバーから取得結果を書き込みます。
・同一であることを念のため確保するため、B列はA列と同じものを書き込みます。

-----------------
動作することを確認していますが、保証するものではありません。
また、スクレイピングに関しての責任は負いかねます。
データの著作権等について十分確認して下さい。

また、サーバーに連続してアクセスすると負荷が掛かり、
これを禁止するところもあります。
そこで、0.2秒の間隔を空けてアクセスするようにしていますが、
これは最低限守ってください。
(連続アクセスをした人が逮捕された"守口図書館事件"が有名です。
 検索してみてください。)

-----------------
なお、今後、「仕様の変更依頼等には一切応じる積もりはありません。」
予めご了解ください。

頻度がそう高いものではないのですから、3時間ですむなら、
今の簡潔なものでも十分と思います。

XMLHt■tpRequestと正規表現を使ったコードを以下に示します。

なお、エイチティーティーピーと言う単語が使用禁止になっていますので、
元に戻してから使用してください。("■"を""に置換すればよいでしょう)

Option Explicit

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Dim re   As Object
Dim Match  As Object
Dim Matches As Object
Dim Ht■tpRequest As Object
Dim mat()  As String

Sub main()
  Dim ws   As Worksheet
  Dim s1   As String
  Dim s2   As String
  Dim s    As String
  Dim uri   As String
  Dim myText As String
  Dim k    As Long
  Dim lastRow As Long
  Dim kosu  As Long
  
  Dim t
  t = Timer
  
  Set Ht■tpRequest = CreateObject("MSXML2.XMLHT■TP.3.0")
  Set re = CreateObject("VBScript.RegExp")
  
  Set ws = Worksheets("結果")
  
  s1 = "ht■tp://hokeninfolist.main.jp/sp/dt"
  s2 = ".html"
  
  lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
  kosu = lastRow - 1
  ReDim mat(1 To kosu, 1 To 5) '一時保持用配列
  
  For k = 1 To kosu
    Sleep 200  ' サーバー負荷を考慮して、0.2秒間隔を空ける
    s = ws.Cells(k + 1, "A").Value
    uri = s1 & s & s2
    
    ' サイトからHTMLファイルを取得
    myText = getHT■TPText(uri)
      
    If myText <> "" Then
      'HTMLを解析して該当項目を取得
      Call setEachDataToMat(myText, k)
    Else
      '何もしない
    End If
  Next
  '結果をシートに貼付
  [B2].Resize(kosu, 5).Value = mat
  
  Debug.Print Timer - t
End Sub

Sub setEachDataToMat(myText As String, k As Long)
  Dim j As Long
  
  '保険者番号,保険者名,郵便番号,住所を取得し、配列matに書込む
  re.pattern = """dt"">(.*?)</div>"
  re.IgnoreCase = True
  re.Global = True
  Set Matches = re.Execute(myText)
  
  j = 1
  For Each Match In Matches
    mat(k, j) = Match.SubMatches(0)
    j = j + 1
    If j >= 5 Then Exit For
  Next
  
  '電話番号
  re.pattern = """dttel""><(?:.*?)>(.*?)</a>"
  Set Matches = re.Execute(myText)
  mat(k, 5) = Replace(Matches(0).SubMatches(0), "&nbsp;", "")
End Sub

Function getHT■TPText(uri As String) As String
  With Ht■tpRequest
    .Open "GET", uri, False
    .send
    'return codeが200でないとき(例:404該当無しなど)
    If Not (.Status >= 200 And _
        .Status < 300) Then
      getHT■TPText = ""
      Exit Function
    End If
    getHT■TPText = .responseText
  End With
End Function

【80862】Re:web クエリの高速化
発言  γ  - 19/6/2(日) 21:14 -

引用なし
パスワード
   結果を書き込むところは、
[B2].Resize(kosu, 5).Value = mat
でなくて、
ws.Range("B2").Resize(kosu, 5).Value = mat
とワークシートを指定しないといけなかったですね。修正下さい。

20件で5秒程度なのでしたので、
3000件だと、10分強で終わるのではないですか?
サーバー側がなんらかの対抗策をとってきたら別ですが。

【80864】Re:web クエリの高速化
発言  γ  - 19/6/2(日) 22:42 -

引用なし
パスワード
   守口図書館事件じゃなく
岡崎図書館事件だった。どうかしてる。
ht tps://ja.wikipedia.org/wiki/%E5%B2%A1%E5%B4%8E%E5%B8%82%E7%AB%8B%E4%B8%AD%E5%A4%AE%E5%9B%B3%E6%9B%B8%E9%A4%A8%E4%BA%8B%E4%BB%B6

【80865】Re:web クエリの高速化
お礼  よし  - 19/6/3(月) 3:16 -

引用なし
パスワード
   >γ さん
ありがとうございます!

所要時間については、投稿時は自分の感覚で時間を書いていましたが、その後作成したものに計測マクロをいれて計測したところ、10件で45秒ぐらいでしたので一件あたり、4.5秒ぐらいでした。

今回Yさんに作成して頂いたマクロを使用したところ、なんと5倍速くなりました!!

ちなみに私も先ほど気付いたのですが、介護保険のみURLの一部である「dt」が「kg」になっているみたいです。ただ、ここの部分については、結果シートやシート名を固定するなどして、IF文を用いて使用できるようにできました!
Yさんのおかげでこれで早く処理できます。

また、岡崎図書館事件の件は勉強になりました。
wikiで内容を読みましたが図書館側、委託の業者が悪いみたいでしたが、複数のアクセスでいらぬ誤解を招くおそれがあることに今後作成していくうえで注意したいと思います。

今後は作成して頂いたマクロを自分なりにも解析し、もっと勉強したいと思います。

ご親切にして頂き本当にありがとうございました!

13 / 13307 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free