Excel VBA質問箱 IV

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

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


234 / 75435 ←次へ | 前へ→

【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

57 hits

【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 発言[未読]

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