VBA Destinationをアクティブセルに

質問

VBA練習中の初心者です。アドバイスをお願いいたします。

WEBクエリの操作をマクロに記録したものを編集しています。
そこで、コード内にあるDestinationをactivecellに指定したいのですが、エラーが治りません。（下記コードの、with文の最初の行の部分です）
通常は、Destination:=Range("A1")と記述されていたものを、編集しました。
どこが間違っているかわかりますでしょうか？
よろしくお願いいたします。

やりたい操作は、WEBクエリをシート（URLTEST）のB２から下に羅列しているURLを順に表示して、シート（データ）に、指定したテーブルを順に貼り付ける操作です。

他にも間違っている部分があると思いますので、何かあった場合、ご指摘お願いいたします。

Sub WEBクエリ連続取得()

Dim I As Integer
I = 1

Do
If I = 1 Then
Worksheets("データ").Activate
Range("A1").Select
Else
Worksheets("データ").Activate
Range("A1").End(xlDown).Offset(1, 0).Select
End If

With ActiveSheet.QueryTables.Add(Connection:="ActiveWorkbook.WorkSheets(""URLTEST"").Cells(""2,I+1"")", Destination:=Activecell)
.Name = "151"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "22"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
I = I + 1

'シート”ボタン”に現在の変数を表示する
Activebook.Worksheets("ボタン").Range("E6").Value (I)

Loop While ActiveWorkbook.Worksheets("URLTEST").Cells("2,I+1") = ""
MsgBox "Finish"

End Sub

回答No.3

real beatin（@realbeatin） · ベストアンサー

こんにちは。＃１、２です。
今頃はＩＥ操作の勉強に忙しいのでしょうか？

＃１補足欄でご指摘の現象がようやく再現できました。
私の方では、ＷＥＢクエリで「テーブル（データベース様のもの）」
を取得するものと考えていましたが、どうやらそうではなかった、
ということなのですね。
＃１の記述では、"データ"シートのＡ列を基準に最下行を取得していました。
＃１の補足欄では、"データ"シートのＡ列に該当するデータの
先頭（一番上のデータ）はブランクだというお話でした。
＃１の記述では、"データ"シートのＡ列をシートの一番下から上に向けて、
Ａ列の最下行（一番下のデータ）を取得しているので、
補足にあったご指摘は関係ないものと思っていましたが、
どうやら、Ａ列の最下行（一番下のデータ）にも
ブランクがある、ということのようです。
実際にＡ列の最下行（一番下のデータ）がブランクのページで
＃１の記述を試してみたところ、
直前にＷＥＢクエリで出力したデータ範囲に対して、
セル範囲の[挿入]（右方向にシフト）する形で、
次のＷＥＢクエリが挿入されてしまう為、
＃１補足欄のように挿入位置がずれる結果になるようです。
ページソースを知っていれば、こんな事にはならなかった、
という面もありますが、改めてこちらから修正を加えておきます。
特定の列を見て最下行を決めるのではなく、
シートの使用済範囲を基に最下行を求め、
その下に次のＷＥＢクエリを挿入するように変えました。
その点、やや冗長な感はありますが、ページソースに対する
汎用性は向上しています。
反面、書式設定等の影響でシートの使用済範囲を
正しく取得できないようなケースでは、挿入位置が見つけられず
エラーになることもあります。
場合によっては、ページソースをレイアウトを基準に
予め各クエリテーブルの行数を決め打ちにして等間隔で
挿入した方がいい、というケースもあるのかも知れません。
修正点を"★"でマークアップしてあります。
今回も、未使用のシート上では、
１件めのクエリテーブルが２行めから挿入されるように書いていますが、
１行めに収めたい場合は、処理の最後で先頭行を削除するようにしてみて下さい。
また、各クエリテーブル間に空行を挿入したい場合は
　　　　　　　　　　　　　　Destination:=.Cells(rUsed(rUsed.Count).Row + 1, "A"))　'　★
の行を
　　　　　　　　　　　　　　Destination:=.Cells(rUsed(rUsed.Count).Row + 2, "A"))　'　★
の書き換えて対応してください。

それでは、また。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

Sub WEBクエリ連続取得Re8927682_()
Dim rngConn As Range
Dim rUsed As Range　'　★
Dim c As Range
Dim sPrgBar As String
Dim s As String
Dim cnConn As Long
Dim i As Long　'　Integer
　　With Sheets("URLTEST")
　　　　Set rngConn = .Range("B2", .Cells(2, "B").End(xlDown))
　　End With
　　cnConn = rngConn.Count
　　sPrgBar = String$(cnConn, "□")

　　Application.ScreenUpdating = False
　　With Worksheets("データ")　　　　
　　　　For Each c In rngConn
　　　　　　s = c.Text
　　　　　　If IsURL(s) Then
　　　　　　　　Set rUsed = .UsedRange　'　★
　　　　　　　　i = i + 1
　　　　　　' ' 現在の進捗状況を　ステータスバーに表示する
　　　　　　　　Mid(sPrgBar, i) = "■"
　　　　　　　　Application.StatusBar = "処理中：【WEBクエリ連続取得】　" & sPrgBar _
　　　　　　　　　　 & "　" & StrConv(i, vbWide) & "　件め　／　全　" & rngConn.Count & "　件"
　　　　　　　　With .QueryTables.Add( _
　　　　　　　　　　　　　　Connection:="URL;" & s, _
　　　　　　　　　　　　　　Destination:=.Cells(rUsed(rUsed.Count).Row + 1, "A"))　'　★
　　　　　　　　　　.Name = "151"
'　　　　　　　　　　.Name = "151-" & i
　　　　　　　　　　.FieldNames = True
　　　　　　　　　　.RowNumbers = False
　　　　　　　　　　.FillAdjacentFormulas = False
　　　　　　　　　　.PreserveFormatting = True
　　　　　　　　　　.RefreshOnFileOpen = False
　　　　　　　　　　.BackgroundQuery = True
　　　　　　　　　　.RefreshStyle = xlInsertDeleteCells
　　　　　　　　　　.SavePassword = False
　　　　　　　　　　.SaveData = True
　　　　　　　　　　.AdjustColumnWidth = True
　　　　　　　　　　.RefreshPeriod = 0
　　　　　　　　　　.WebSelectionType = xlSpecifiedTables
　　　　　　　　　　.WebFormatting = xlWebFormattingNone
　　　　　　　　　　.WebTables = "2"
　　　　　　　　　　.WebPreFormattedTextToColumns = True
　　　　　　　　　　.WebConsecutiveDelimitersAsOne = True
　　　　　　　　　　.WebSingleBlockTextImport = False
　　　　　　　　　　.WebDisableDateRecognition = False
　　　　　　　　　　.WebDisableRedirections = False
　　　　　　　　　　.Refresh BackgroundQuery:=False
　　　　　　　　　　.Delete　'　データだけ残すなら、クエリテーブルのみ削除
　　　　　　　　End With
　　　　　　Else
　　　　　　　　MsgBox c.Address(0, 0) & "セル" & vbLf _
　　　　　　　　　　& s & vbLf & "ＵＲＬが正しいか確認してください", vbExclamation
　　　　　　End If
　　　　Next
　　End With
　　Set rUsed = Nothing　'　★
　　Application.StatusBar = ""
　　Application.ScreenUpdating = True
　　MsgBox "Finish　" & i
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Function IsURL(ByVal s As String) As Boolean
　　If Not s Like "http*" Then Exit Function
　　Select Case InStr(s, "://")
　　Case 5, 6
　　Case Else: Exit Function
　　End Select
　　If s <> StrConv(s, vbNarrow) Then Exit Function
　　If s Like "*[" & Chr(1) & "- """ & Chr(39) & "-)<>[\-^`{-}" _
　　　　　　& Chr(127) & "-" & Chr(160) & Chr(161) & "-" & Chr(223) _
　　　　　　& Chr(224) & "-" & Chr(255) & "]*" _
　　　　　　Then Exit Function
　　IsURL = True
End Function

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

お礼

お礼が遅くなり申し訳ありません。体調がすぐれず、一時パソコンから離れておりましたm(__)m
realbeatinさんの親身なご対応大変感謝いたします。

私の説明不足が問題ですが、（ソース提示できず申し訳ございませんm(__)m）
destination部分を
Destination:=.Cells(Rows.Count, "C").End(xlUp).Offset(1, -2)
にて解決することができました。
前補足覧で、困惑させてしまったみたいです。対象テーブルのブランクがある部分は、先頭行の左２つと、左端列の下段部分にも存在しておりました。

再提案していただいた、コードですが、まだ実行しただけの段階ですが、何故か貼り付け位置のずれを解消することができませんでした。原因をこれから調べてみたいと思います。
いずれにしても、変数、引数の使い方、WITHの抜けた後のコードなど、勉強になる部分を教えていただき、非常に感謝いたします。

>>私の方では、ＷＥＢクエリで「テーブル（データベース様のもの）」
>>を取得するものと考えていましたが、どうやらそうではなかった、
>>ということなのですね。
テーブルはテーブルなのですが、左端にあたる部分が整列番号であり、後半は省略されているソースのものでした。ソースを提示できず申し訳ありません。

>>どうやら、Ａ列の最下行（一番下のデータ）にもブランクがある、ということのようで>>す。
ご指摘の通りです。

このたびは、ありがとうございました。非常に勉強になりました。

回答No.2

real beatin（@realbeatin）

＃１です。＃１補足拝見しました。

とりあえず、＃１の記述の
　　　　　　　　With .QueryTables.Add( _
　　　　　　　　　　　　　　Connection:="URL;" & s, _
　　　　　　　　　　　　　　Destination:=.Cells(Rows.Count, "A").End(xlUp).Offset(1))
を
　　　　　　　　With .QueryTables.Add( _
　　　　　　　　　　　　　　Connection:="URL;" & s, _
　　　　　　　　　　　　　　Destination:=.Cells(Rows.Count, "A").End(xlUp).Offset(1 + (i = 1)))
に書き換えてみる、ということ？なのでしょうか。

Ａ列がすべて空セルに場合には、
　　.Cells(Rows.Count, "A").End(xlUp).Offset(1)
が、Ａ２セルを指しますので、最初のテーブルの貼付け位置はＡ２になるように書いていました。
通常は、１行めを大項目やタイトルに使う可能性を意識して、
そのまま１行めを空行にしておくような（ある意味手抜き）処理
を提示することも多いです。

こちらが書く記述は、元質問の記述を踏襲して、
A列はすべてブランク（空列）、という前提で書いています。
幾つかのテーブルデータが既存の状態から実行すると、
実行時の最初のテーブルが、既存のテーブルの一番下のレコードを上書きしてしまいます。
なので、現実的には、上記の書換えはトラブルの元になりますし、
ある意味邪道です。
ですので、この点については、上記の書換えをせずに、
必要なら、Rows(1).Delete とかを追加した方が対応としてはマトモかも知れません。

さて、
何やらうまく行っていない、、、
という結果をもたらす原因は、＃１で提示したコードには在りません。
原因として考えられる第一の可能性は、（存在を目視出来ない場合もある―）
以前から取り残されているWorksheets("データ")上のWebクエリ、です。
差し当たり、一旦、
手作業でWorksheets("データ")のセルを全選択して、
[すべてクリア]を実行し、Webクエリすべを含むセルデータすべてを削除
してから、＃１を実行してみて下さい。
（↑動作を確認する目的ですので。）

最初に書いた書換えをしていなければ、1行めは空行、
最初に書いた書換えをしていれば、最初のテーブルは１行めに貼付け、
という結果になる筈です。

以上のことを確認しながら実践し、
それでも
> １つ目のＵＲＬのデータは貼り付けされず、
> ２つ目のＵＲＬは、Ｋ３０あたりから貼り付けされ、
> ３つ目は、その下、４つ目は、その左側と、おかしな配置になってしまっていました。
というような異常な結果になる場合は、
第ニの可能性として考えられるのは、ページソースです。
対策については、
その問題が発生するページのＵＲＬを知ることか
HTMLソースを目にすること、からしか、
こちらでは考えることが出来ませんので、
差支えなければ、「４つのＵＲＬ」を情報として追加してください。

もしも、ですが、＃１で提供したものを編集した上でテストしている場合は、
まず、編集ポイントの処理内容を確認してください。

他にそちらでできることとして、
テストに使った「４つのＵＲＬ」について、マクロの記録を録りながら、
手作業でＷｅｂクエリ挿入してみて、
データが正しく配置されるか、
テーブル指定は、.WebTables = "22"　で合っているか、
その他、引数の指定に誤りがないか、
確認してみるのもいいでしょう。

> しかし恐縮ながら、１点だけ、「データの貼り付け先」がずれてしまう問題が出てしまいました。
>
> 説明不足で申し訳ございません。
> 取り込みたいデータの先頭行の左２つ（A1、B1にあたる部分）が、空白であり、その点を考慮しておかなければなりませんでした。
>
> イメージは下のような形です。

ちょっと私の理解が至ってないのかも知れませんが、
そういう結果になる処理を求めている、ということでしたら、
元のテーブルがどのようなレイアウトなのか、
それぞれのデータをシート上の何処に反映させるかの対応関係、
等、知らないと、何も手出しで出来ないです。

＃１のコードに書いた、
　　　　　　　　　　.Delete　'　データだけ残すなら、クエリテーブルのみ削除
ですが、
個々クエリテーブルを後々も継続的に更新する必要がある、
のでなければ、都度都度、データだけ残しクエリテーブルは削除する
（使わないクエリは削除する）ように運用していかないと、
ＷｅｂクエリはExcel全体のパフォーマンスにも影響が大きいですから、
余計なトラブルを招くことにも繋がりかねません。
既存のシートに対して[すべてクリア]する訳に行かない場合、
以下のマクロを使ってみて下さい。

' ' ----- ActiveSheetのWebクエリ　クエリのみ削除
Sub DelQ()
Dim oQ As QueryTable, cn&
　　For Each oQ In ActiveSheet.QueryTables
　　　　oQ.Delete
　　　　cn = cn + 1
　　Next
　　MsgBox cn & "　点のWebクエリを削除しました"
End Sub
' ' -----
' ' ----- ActiveSheetのWebクエリ　クエリ＋テーブルデータを削除
Sub DelQR()
Dim oQ As QueryTable, cn&
　　For Each oQ In ActiveSheet.QueryTables
　　　　oQ.ResultRange.ClearContents
　　　　oQ.Delete
　　　　cn = cn + 1
　　Next
　　MsgBox cn & "　点のWebクエリを削除しました"
End Sub
' ' -----

取り急ぎ、補足への返答は、以上です。

回答No.1

real beatin（@realbeatin）

こんにちは。

エラーになる部分は何ヶ所かあるようですが、
差し当たり問題にされている部分は、DestinationよりもConnection
の問題です。
先頭に"URL;"を付けて指定するということと、
セルの値（URL）を取得すること、が出来ていませんので、
Connectionで引っ掛かっています。

とりあえず、
ご提示の記述を基に、こちらの環境でテキトーなＷｅｂページの
テキトーなテーブルデータを連続取得するという仮の課題を設けて、
動くように書いてみました。
ページソースやお使いのＰＣ（ＯＳ／ＩＥ）環境によって、
Ｗｅｂクエリ機能の挙動は大きく変わる可能性がありますので、
Ｗｅｂクエリがうまく機能しないようでしたら、他の方法も検討してみてください。
Ｗｅｂクエリをループで処理するのは、現在では、
それを安定的に機能させる意味では、結構難度の高い課題です。
変な言い方ですが、これを使いこなせる技術があれば、
もっと他の（高パフォーマンスな）方法を選ぶ、という風潮（傾向）があるようで、
（今時の）Ｗｅｂクエリの扱いに長けた方は、なかなか居られないように思います。
（実は私もあまり知らないんです。）
中間的な難易度で言えば、ＩＥ（InternetExplorer）
　[ SHDocVw － Microsoft Internet Controls ]
　[ MSHTML － Microsoft HTML Object Library ]
等の扱いを、少し難しく感じたとしても、頑張って
ご自分で覚えていった方が人によっては好いとお感じになるのかも知れません。
▽▽▽　参考　▽▽▽
Webページ
『IEを使用して、Web上の表をExcelへ』
http://www.ken3.org/vba/backno/vba119.html
書籍
『IEを自在に操るExcel VBAプログラミング入門』
△△△△△△△△△△

もっとも、旧来型の簡易な造りの易しいページソースであれば、
Ｗｅｂクエリでも十分満足出来るパフォーマンスは得られるかとは思います。
ここら辺は実際、何をやるにもページ次第です。

///
以下の記述を（過不足なく）モジュールに貼り付けてテストしてみてください。

もし、不足があれば詳しい補足をお願いします。

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

Sub WEBクエリ連続取得Re8927682()
Dim rngConn As Range
Dim c As Range
Dim sPrgBar As String
Dim s As String
Dim cnConn As Long
Dim i As Long

　　With Sheets("URLTEST")
　　　　Set rngConn = .Range("B2", .Cells(2, "B").End(xlDown))
　　End With

　　cnConn = rngConn.Count
　　sPrgBar = String$(cnConn, "□")

　　Application.ScreenUpdating = False

　　With Worksheets("データ")

　　　　For Each c In rngConn

　　　　　　s = c.Text

　　　　　　If IsURL(s) Then

　　　　　　　　i = i + 1
　　　　　　' ' 現在の進捗状況を　ステータスバーに表示する
　　　　　　　　Mid(sPrgBar, i) = "■"
　　　　　　　　Application.StatusBar = "処理中：【WEBクエリ連続取得】　" & sPrgBar _
　　　　　　　　　　 & "　" & StrConv(i, vbWide) & "　件め　／　全　" & rngConn.Count & "　件"

　　　　　　　　With .QueryTables.Add( _
　　　　　　　　　　　　　　Connection:="URL;" & s, _
　　　　　　　　　　　　　　Destination:=.Cells(Rows.Count, "A").End(xlUp).Offset(1))

　　　　　　　　　　.Name = "151"
　　　　　　　　　　.FieldNames = True
　　　　　　　　　　.RowNumbers = False
　　　　　　　　　　.FillAdjacentFormulas = False
　　　　　　　　　　.PreserveFormatting = True
　　　　　　　　　　.RefreshOnFileOpen = False
　　　　　　　　　　.BackgroundQuery = True
　　　　　　　　　　.RefreshStyle = xlInsertDeleteCells
　　　　　　　　　　.SavePassword = False
　　　　　　　　　　.SaveData = True
　　　　　　　　　　.AdjustColumnWidth = True
　　　　　　　　　　.RefreshPeriod = 0
　　　　　　　　　　.WebSelectionType = xlSpecifiedTables
　　　　　　　　　　.WebFormatting = xlWebFormattingNone
　　　　　　　　　　.WebTables = "22"
　　　　　　　　　　.WebPreFormattedTextToColumns = True
　　　　　　　　　　.WebConsecutiveDelimitersAsOne = True
　　　　　　　　　　.WebSingleBlockTextImport = False
　　　　　　　　　　.WebDisableDateRecognition = False
　　　　　　　　　　.WebDisableRedirections = False
　　　　　　　　　　.Refresh BackgroundQuery:=False
　　　　　　　　　　.Delete　'　データだけ残すなら、クエリテーブルのみ削除
　　　　　　　　End With
　　　　　　Else
　　　　　　　　MsgBox c.Address(0, 0) & "セル" & vbLf _
　　　　　　　　　　& s & vbLf & "ＵＲＬが正しいか確認してください", vbExclamation
　　　　　　End If
　　　　Next

　　End With

　　Application.StatusBar = ""
　　Application.ScreenUpdating = True
　　MsgBox "Finish　" & i
End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Function IsURL(ByVal s As String) As Boolean
　　If Not s Like "http*" Then Exit Function
　　Select Case InStr(s, "://")
　　Case 5, 6
　　Case Else: Exit Function
　　End Select
　　If s <> StrConv(s, vbNarrow) Then Exit Function
　　If s Like "*[" & Chr(1) & "- """ & Chr(39) & "-)<>[\-^`{-}" _
　　　　　　& Chr(127) & "-" & Chr(160) & Chr(161) & "-" & Chr(223) _
　　　　　　& Chr(224) & "-" & Chr(255) & "]*" _
　　　　　　Then Exit Function
　　IsURL = True
End Function

' ' 〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓〓

補足

ありがとうございます。ご丁寧な回答を頂き、感激しております。

私も、WEBクエリを使わない方法での、データ抽出を実践しようと考えておりましたが、なかなか難しく後回しにしておりました。そして、実は、昨日回答者さんの回答を拝見する前に、紹介していただいてる書籍を購入したので、今びっくりしていたところです。

コードですが、
コピーさせていただいたところ、スムーズに処理を行うことができました。
ステータスバーやfuncitonの使い方など大変勉強になります。

しかし恐縮ながら、１点だけ、「データの貼り付け先」がずれてしまう問題が出てしまいました。

説明不足で申し訳ございません。
取り込みたいデータの先頭行の左２つ（A1、B1にあたる部分）が、空白であり、その点を考慮しておかなければなりませんでした。

イメージは下のような形です。

　ＡＢＣＤＥ
１空空デデデ　←１つめのＵＲＬのデータ
２デデデデデ　←１つめのＵＲＬのデータ
３デデデデデ　←１つめのＵＲＬのデータ
４空空デデデ　←２つめのＵＲＬのデータ
５デデデデデ
６デデデデデ

現在の状態は、具体的には、４つのＵＲＬでテストを行ったところ、
１つ目のＵＲＬのデータは貼り付けされず、
２つ目のＵＲＬは、Ｋ３０あたりから貼り付けされ、
３つ目は、その下、４つ目は、その左側と、おかしな配置になってしまっていました。

厚かましくて申し訳ありませんが、編集方法をご教授いただけると大変ありがたく存じます。
まだまだ、理解が足りていないようですm(__)m