Webクエリで困っています

質問

以下のマクロを作りました。Webクエリで、セルA1に入力してあるURLを読み込んで表を取り込み、必要なところを選択してコピーするようにしたいのです。しかし、実行すると上から3行目まで黄色になってエラーになります。特に3行目には矢印が表示されています。いろいろ調べましたが結局分かりませんでした。宜しくお願いします。

------------------------------------------------------
Sub クエリで取得()
'
' クエリで取得 Macro
' マクロ記録日 : 2009/7/30 ユーザー名 : charlie
'

'
With ActiveSheet.QueryTables.Add(Connection:= _
Range("A1").Value _
, Destination:=Range("A2"))
.Name = "resultlist?tbws=x0p01a&hd=20090716&jcd=01_2"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
Range("A19:Q54").Select
Selection.Copy
End Sub
----------------------------------------------------------

回答No.2

KenKen_SP · ベストアンサー

下記で試してみて。

URL の簡易チェックで Like 演算子を使うため、大小文字の統一の
必要があり、Lcase 関数で URL を小文字化してたのが原因かも。

Sub クエリで取得()

　　Dim sConnectionStr As String
　　Dim sh　　　　　As Worksheet

　　Set sh = Worksheets("クエリで取得")

　　sConnectionStr = Trim$(sh.Range("A1").Text)

　　If Len(sConnectionStr) = 0 Then Exit Sub

　　If LCase$(sConnectionStr) Like "http://*" Or _
　　　 LCase$(sConnectionStr) Like "https://*" Then

　　　　sh.Rows("2:" & CStr(sh.Rows.Count)).ClearContents
　　　　sConnectionStr = "URL;" & sConnectionStr
　　　　With sh.QueryTables.Add(Connection:=sConnectionStr, _
　　　　　　　　　　　　　　　　Destination:=sh.Range("A2"))
　　　　　　.FillAdjacentFormulas = False
　　　　　　.PreserveFormatting = False
　　　　　　.RefreshStyle = xlOverwriteCells
　　　　　　.AdjustColumnWidth = False
　　　　　　.RefreshPeriod = 0
　　　　　　.WebSelectionType = xlEntirePage
　　　　　　.WebFormatting = xlWebFormattingNone
　　　　　　.WebPreFormattedTextToColumns = True
　　　　　　.WebConsecutiveDelimitersAsOne = True
　　　　　　.WebSingleBlockTextImport = False
　　　　　　.WebDisableDateRecognition = True
　　　　　　.WebDisableRedirections = False
　　　　　　.Refresh BackgroundQuery:=False
　　　　　　.Delete
　　　　End With

　　　　sh.Range("A19:Q54").Copy

　　Else
　　　　MsgBox "A1 セルが未入力か URL として不適切", vbInformation
　　End If

End Sub

お礼

いやっ！できました！！！
感動です。イメージ通りのものができました。
感謝！感謝！感謝！です。
いろいろご親切にこちらのわがままを聞いて頂いて恐縮です。ありがとうございました。
いつも、『新しいマクロの記録』から作成して、不要な部分を削除する方法で作っていました。今回変数をはじめて知りました。いろいろなことができそうですね。難しそうですが、勉強してみます。
ありがとうございましたm(__)m

回答No.1

KenKen_SP

QueryTables.Add(Connection:=～ に URL を指定する場合、URL であることを
表す "URL;" というキーワードが必要（下記ソースの※のライン）です。

また、不要と思われる各種プロパティー設定は多少整理しました。

下記ソースを VBE にコピー＆ペーストすると http:// の部分で余計な「？」
記号までペーストされますが、削除して下さい。

Sub クエリで取得()

　　Dim sConnectionStr As String
　　Dim sh　　　　　　 As Worksheet

　　' WEB クエリを作成するシートを参照
　　Set sh = ActiveSheet ' または Worksheets("シート名")

　　' 前処理：余計なホワイトスペース等を除去し、Like 演算子で比較
　　' できるように小文字化しておく
　　sConnectionStr = Trim$(LCase$(sh.Range("A1").Text))

　　' A1 にはデータが入力されていて、かつ http:// で始まっているか
　　If Len(sConnectionStr) And sConnectionStr Like "http://*" Then

　　　　' 前処理：一応シートをクリアした方が良いでしょう
　　　　sh.Rows("2:" & CStr(sh.Rows.Count)).ClearContents

　　　　' ※POINT： 接続文字列に URL であることを表すキーワードを付与
　　　　sConnectionStr = "URL;" & sConnectionStr

　　　　' WEB クエリを作成する
　　　　With sh.QueryTables.Add(Connection:=sConnectionStr, _
　　　　　　　　　　　　　　　　Destination:=sh.Range("A2"))
　　　　　　.FillAdjacentFormulas = False
　　　　　　.PreserveFormatting = False
　　　　　　.RefreshStyle = xlOverwriteCells
　　　　　　.AdjustColumnWidth = False
　　　　　　.RefreshPeriod = 0
　　　　　　.WebSelectionType = xlEntirePage
　　　　　　.WebFormatting = xlWebFormattingNone
　　　　　　.WebPreFormattedTextToColumns = True
　　　　　　.WebConsecutiveDelimitersAsOne = True
　　　　　　.WebSingleBlockTextImport = False
　　　　　　.WebDisableDateRecognition = True
　　　　　　.WebDisableRedirections = False
　　　　　　' 実際にインポートするには Refresh メソッドを実行する
　　　　　　' 今回はインポートが完了するまで待機する必要があるので、
　　　　　　' BackgroundQuery は False にしておく
　　　　　　.Refresh BackgroundQuery:=False
　　　　　　' WEB クエリを繰り返し更新する必要がなければ
　　　　　　' 削除した方が省リソースです
　　　　　　.Delete
　　　　End With

　　　　sh.Range("A19:Q54").Copy

　　Else
　　　　MsgBox "A1 セルが未入力か URL として不適切", vbInformation
　　End If

End Sub

補足

Sub クエリで取得()
'
' クエリで取得 Macro
' マクロ記録日 : 2009/8/1 ユーザー名 : charlie
'

Dim sConnectionStr As String
Dim sh As Worksheet
Set sh = Worksheets("クエリで取得")
sConnectionStr = Trim$(LCase$(sh.Range("A1").Text))
If Len(sConnectionStr) And sConnectionStr Like "https://*" Then
sh.Rows("2:" & CStr(sh.Rows.Count)).ClearContents
sConnectionStr = "URL;" & sConnectionStr
With sh.QueryTables.Add(Connection:=sConnectionStr, _
Destination:=sh.Range("A2"))
.FillAdjacentFormulas = False
.PreserveFormatting = False
.RefreshStyle = xlOverwriteCells
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = True
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
.Delete
End With

sh.Range("A19:Q54").Copy

Else
MsgBox "A1 セルが未入力か URL として不適切", vbInformation
End If

End Sub

-------------------
上記のように修正しましたが、
.Refresh BackgroundQuery:=Falseで黄色のエラーになります。
どうしたらよいでしょうか。
尚、http://をhttps://にしました。
宜しくお願いします。