マクロのWEBデータの取り込み

質問

下のように書いてマクロを実行したのですが（EXCEL2003）

Sheet1のA1からDP１０００のデータをクリアにしてから
URLのデータを取り込んで
D列の最終行の値を
Sheet2のA列の日付+１行に書き込みたいのですが

Sheet1のA1からDP１０００のデータをクリアにする前に
D列の最終行の値を
Sheet2のA列の日付+１行に書き込んでしまいます。

あとConst Col = 4の部分が
同じ範囲内で宣言が重複しています。
とエラーになります。

どこが悪いのかがわかりません。
よろしくお願いします。

Sub 抽出()

Worksheets("Sheet1").Range("A1:DP1000").Value = ""

nen = InputBox("読み込む年度、西暦４桁（半角）読み込む月（半角）を入力")
tuki = InputBox("読み込む日（半角）を入力")
strUrl= "URL;http://○○○○★★★★DATFR=#01&DATTO=#$&MSCD=1431&BMCD=30&MENU_ID=2&MENU_ID1=2"

strnen = Mid(Str(nen), 2)
strtuki = Mid(Str(tuki), 2)
strUrl = Replace(Replace(strUrl, "$", strtuki), "#", strnen)
strName = Replace(Replace(strName, "$", strtuki), "#", strnen)
With Worksheets("野菜").QueryTables.Add(Connection:=strUrl, Destination:=Worksheets("Sheet1").Range("A1"))
.Name = strtuki
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True

End With

Const Col = 4
Dim Rw As Long
With Sheets("Sheet1")
Rw = .Cells(Rows.Count, Col).End(xlUp).Row
Sheets("Sheet2").Range("A" & tuki + 1 & ":A" & tuki + 1).Value = _
.Range(.Cells(Rw, 4), .Cells(Rw, 4)).Value
End With

strUrl= "URL;http://○○○○■■■■DATFR=#01&DATTO=#$&MSCD=1431&BMCD=30&MENU_ID=2&MENU_ID1=2"

strnen = Mid(Str(nen), 2)
strtuki = Mid(Str(tuki), 2)
strUrl = Replace(Replace(strUrl, "$", strtuki), "#", strnen)
strName = Replace(Replace(strName, "$", strtuki), "#", strnen)
With Worksheets("Sheet3").QueryTables.Add(Connection:=strUrl, Destination:=Worksheets("Sheet3").Range("A1"))
.Name = strtuki
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True

End With

Const Col = 4
Dim Rw As Long
With Sheets("Sheet3")
Rw = .Cells(Rows.Count, Col).End(xlUp).Row
Sheets("Sheet4").Range("A" & tuki + 1 & ":A" & tuki + 1).Value = _
.Range(.Cells(Rw, 4), .Cells(Rw, 4)).Value
End With

End Sub

回答No.1

goota33

二か所ほど変更したので試してみてください。
一か所目はSheet1のA1からDP1000のデータをクリアにする前にD列の最終行の値を
Sheet2のA列の日付+１行に書き込んでしまうとのことだったので、
変数RwにD列の最後の値を取得させたあと、
すぐA1からDP1000までの範囲をクリアするようにしました。

二か所目は同じ関数内に二回同じ変数の名前を宣言することはできないので
その宣言の部分を削除しました。
変更した場所はコメントアウトで書いておいたので参考にしてください。

Sub 抽出()
Worksheets("Sheet1").Range("A1:DP1000").Value = ""
nen = InputBox("読み込む年度、西暦４桁（半角）読み込む月（半角）を入力")
tuki = InputBox("読み込む日（半角）を入力")
strUrl = "URL;http://○○○○★★★★DATFR=#01&DATTO=#$&MSCD=1431&BMCD=30&MENU_ID=2&MENU_ID1=2"

strnen = Mid(Str(nen), 2)
strtuki = Mid(Str(tuki), 2)
strUrl = Replace(Replace(strUrl, "$", strtuki), "#", strnen)
strName = Replace(Replace(strName, "$", strtuki), "#", strnen)
With Worksheets("野菜").QueryTables.Add(Connection:=strUrl, Destination:=Worksheets("Sheet1").Range("A1"))
.Name = strtuki
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True

End With

Const Col = 4
Dim Rw As Long

With Sheets("Sheet1")
Rw = .Cells(Rows.Count, Col).End(xlUp).Row
'変更箇所
'D列の最終行の値を取得してからSheet1の内容をクリア
Worksheets("Sheet1").Range("A1:DP1000").Clear
Sheets("Sheet2").Range("A" & tuki + 1 & ":A" & tuki + 1).Value = _
.Range(.Cells(Rw, 4), .Cells(Rw, 4)).Value

End With

strUrl = "URL;http://○○○○■■■■DATFR=#01&DATTO=#$&MSCD=1431&BMCD=30&MENU_ID=2&MENU_ID1=2"

strnen = Mid(Str(nen), 2)
strtuki = Mid(Str(tuki), 2)
strUrl = Replace(Replace(strUrl, "$", strtuki), "#", strnen)
strName = Replace(Replace(strName, "$", strtuki), "#", strnen)
With Worksheets("Sheet3").QueryTables.Add(Connection:=strUrl, Destination:=Worksheets("Sheet3").Range("A1"))
.Name = strtuki
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlEntirePage
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=True

End With

'変更箇所
'Const Col = 4
'Dim Rw As Long
'の二行を削除
'同じ関数内で同じ変数名を二回宣言することはできません。
With Sheets("Sheet3")
Rw = .Cells(Rows.Count, Col).End(xlUp).Row
Sheets("Sheet4").Range("A" & tuki + 1 & ":A" & tuki + 1).Value = _
.Range(.Cells(Rw, 4), .Cells(Rw, 4)).Value

End With

End Sub

補足

回答ありがとうございます。
'同じ関数内で同じ変数名を二回宣言の方は
'Const Col = 4
'Dim Rw As Long
を削除してうまくいきました。

一か所目の方ですが説明不足だった為にうまく伝わらなかったのですね。ごめんなさい。

URLのデータを取り込む前に
下の処理をしてしまいます。

Const Col = 4
Dim Rw As Long

With Sheets("Sheet1")
Rw = .Cells(Rows.Count, Col).End(xlUp).Row
Sheets("Sheet2").Range("A" & tuki + 1 & ":A" & tuki + 1).Value = _
.Range(.Cells(Rw, 4), .Cells(Rw, 4)).Value

よろしくお願いします。