Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

1606 / 76807

←次へ　｜　前へ→


	【80851】web クエリの高速化

よし - 19/6/1(土) 2:10 -


	引用なし

	パスワード

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

この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

1 hits

▼

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