Hello,

I have a spreadsheet that contains some descriptive fields, including
a URL field. I'm trying to create a macro that will do a webquery
into a separate worksheet (Sheet3) and then copy and paste the values
of two separate cells into two new fields in the original worksheet
(Sheet1), then move down to the next row and do it again until it
reaches the end. There is an intermediary sheet for copying and
pasting the url called Sheet2 There are 18174 rows and it gets to
about row 50 or 60 before it gets hung up with Connecting to the
web... at the bottom of the screen. Any ideas on how I can get it to
power through the whole table? Here is the code (apologies for the
length):

Sub eval_loop()
'
' eval_loop Macro
'

'
Dim i As Integer
Dim iLoop As Integer
Dim iCell As Range
Dim lCell As Range
Dim rCell As Range

i = 1
iLoop = WorksheetFunction.CountA(Columns(1))

Set iCell = ActiveWorkbook.Worksheets("Sheet1").Range("D1704")
Set lCell = ActiveWorkbook.Worksheets("Sheet1").Range("F1704")
Set rCell = ActiveWorkbook.Worksheets("Sheet1").Range("G1704")

Do Until i = iLoop

iCell.Select

Dim MyURL As String
Dim QuitTime As Date

Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
MyURL = Range("A1").Text
Sheets("Sheet3").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & MyURL _
, Destination:=Range("$A$1"))
.Name = _ "productDetail.do?
oid=171960&WT.mc_n=58&WT.mc_t=U&cm_ven=PAID
%20SEARCH&cm_cat=ADVERTISING.COM&cm_pla=DATAFEED-
PRODUCTS&cm_ite=1%20PRODUCT&cm_keycode=58_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.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:=False
End With
Range("A32").Select
Selection.Copy
Sheets("Sheet1").Select
lCell.Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Range("A77").Select
Selection.Copy
Sheets("Sheet1").Select
rCell.Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Cells.Select
Range("A46").Activate
Selection.QueryTable.Delete
Selection.ClearContents
Sheets("Sheet2").Select
Range("A1").Select
Selection.ClearContents

Sheets("Sheet1").Select

Set iCell = iCell.Offset(1, 0)
Set lCell = lCell.Offset(1, 0)
Set rCell = rCell.Offset(1, 0)

i = i + 1
Loop
End Sub

It's possible that if you're querying an external site they have some
mechanism to prevent this type of activity.

Tim

"excel_is_evil" wrote in message
...
Hello,

I have a spreadsheet that contains some descriptive fields, including
a URL field. I'm trying to create a macro that will do a webquery
into a separate worksheet (Sheet3) and then copy and paste the values
of two separate cells into two new fields in the original worksheet
(Sheet1), then move down to the next row and do it again until it
reaches the end. There is an intermediary sheet for copying and
pasting the url called Sheet2 There are 18174 rows and it gets to
about row 50 or 60 before it gets hung up with Connecting to the
web... at the bottom of the screen. Any ideas on how I can get it to
power through the whole table? Here is the code (apologies for the
length):

Sub eval_loop()
'
' eval_loop Macro
'

'
Dim i As Integer
Dim iLoop As Integer
Dim iCell As Range
Dim lCell As Range
Dim rCell As Range

i = 1
iLoop = WorksheetFunction.CountA(Columns(1))

Set iCell = ActiveWorkbook.Worksheets("Sheet1").Range("D1704")
Set lCell = ActiveWorkbook.Worksheets("Sheet1").Range("F1704")
Set rCell = ActiveWorkbook.Worksheets("Sheet1").Range("G1704")

Do Until i = iLoop

iCell.Select

Dim MyURL As String
Dim QuitTime As Date

Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
MyURL = Range("A1").Text
Sheets("Sheet3").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & MyURL _
, Destination:=Range("$A$1"))
.Name = _ "productDetail.do?
oid=171960&WT.mc_n=58&WT.mc_t=U&cm_ven=PAID
%20SEARCH&cm_cat=ADVERTISING.COM&cm_pla=DATAFEED-
PRODUCTS&cm_ite=1%20PRODUCT&cm_keycode=58_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.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:=False
End With
Range("A32").Select
Selection.Copy
Sheets("Sheet1").Select
lCell.Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Range("A77").Select
Selection.Copy
Sheets("Sheet1").Select
rCell.Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Cells.Select
Range("A46").Activate
Selection.QueryTable.Delete
Selection.ClearContents
Sheets("Sheet2").Select
Range("A1").Select
Selection.ClearContents

Sheets("Sheet1").Select

Set iCell = iCell.Offset(1, 0)
Set lCell = lCell.Offset(1, 0)
Set rCell = rCell.Offset(1, 0)

i = i + 1
Loop
End Sub

"excel_is_evil" wrote in message
...
Hello,

I have a spreadsheet that contains some descriptive fields, including
a URL field. I'm trying to create a macro that will do a webquery
into a separate worksheet (Sheet3) and then copy and paste the values
of two separate cells into two new fields in the original worksheet
(Sheet1), then move down to the next row and do it again until it
reaches the end. There is an intermediary sheet for copying and
pasting the url called Sheet2 There are 18174 rows and it gets to
about row 50 or 60 before it gets hung up with Connecting to the
web... at the bottom of the screen. Any ideas on how I can get it to
power through the whole table? Here is the code (apologies for the
length):

You seem to be trying to create 18174 web queries.

If you only need one, then move the "ActiveSheet.QueryTables.Add" part out
of the loop.

If you need all of them, then try deleting them after use - perhaps that
will help.

--
roger


Sub eval_loop()
'
' eval_loop Macro
'

'
Dim i As Integer
Dim iLoop As Integer
Dim iCell As Range
Dim lCell As Range
Dim rCell As Range

i = 1
iLoop = WorksheetFunction.CountA(Columns(1))

Set iCell = ActiveWorkbook.Worksheets("Sheet1").Range("D1704")
Set lCell = ActiveWorkbook.Worksheets("Sheet1").Range("F1704")
Set rCell = ActiveWorkbook.Worksheets("Sheet1").Range("G1704")

Do Until i = iLoop

iCell.Select

Dim MyURL As String
Dim QuitTime As Date

Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
MyURL = Range("A1").Text
Sheets("Sheet3").Select
Range("A1").Select
With ActiveSheet.QueryTables.Add(Connection:= _
"URL;" & MyURL _
, Destination:=Range("$A$1"))
.Name = _ "productDetail.do?
oid=171960&WT.mc_n=58&WT.mc_t=U&cm_ven=PAID
%20SEARCH&cm_cat=ADVERTISING.COM&cm_pla=DATAFEED-
PRODUCTS&cm_ite=1%20PRODUCT&cm_keycode=58_1"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.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:=False
End With
Range("A32").Select
Selection.Copy
Sheets("Sheet1").Select
lCell.Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Range("A77").Select
Selection.Copy
Sheets("Sheet1").Select
rCell.Select
ActiveSheet.Paste
Sheets("Sheet3").Select
Cells.Select
Range("A46").Activate
Selection.QueryTable.Delete
Selection.ClearContents
Sheets("Sheet2").Select
Range("A1").Select
Selection.ClearContents

Sheets("Sheet1").Select

Set iCell = iCell.Offset(1, 0)
Set lCell = lCell.Offset(1, 0)
Set rCell = rCell.Offset(1, 0)

i = i + 1
Loop
End Sub