CODEWITHSUNDEEP
excelexcel-2013vba
T.C.
T.C.

Reputation: 13

VBA Run-Time Error 1004 After 29738 Rows

Good Day everyone. I'm new to VBA and was working with the following code to figure out how to query multiple tables. I would like the code to go to 100000 rows but I wanted to see how far it could actually run. Sadly, after the 29714th row, it gave me : Run-Time error 1004 'Application-defined or object-defined error'. I don't have a clue as to what is wrong other than the loop parameters might be too big. Any ideas?

Sub Data()

Dim qtb As New QueryTable
Dim url1 As String
Dim i As Long

For i = 2 To 540602 Step 24
url1 = Sheet2.Range("A" & i)

Set qtb = Sheet2.QueryTables.Add(Connection:="URL;" & url1, Destination:=Range("B" & i))
    qtb.WebTables = "5"
    qtb.FieldNames = True
    qtb.RowNumbers = False
    qtb.FillAdjacentFormulas = False
    qtb.PreserveFormatting = True
    qtb.RefreshOnFileOpen = False
    qtb.BackgroundQuery = False
    qtb.RefreshStyle = xlInsertDeleteCells
    qtb.SavePassword = False
    qtb.SaveData = False
    qtb.AdjustColumnWidth = False
    qtb.RefreshPeriod = 0
    qtb.WebSelectionType = xlSpecifiedTables
    qtb.WebFormatting = xlWebFormattingNone
    qtb.WebPreFormattedTextToColumns = True
    qtb.WebConsecutiveDelimitersAsOne = True
    qtb.WebSingleBlockTextImport = False
    qtb.WebDisableDateRecognition = False
    qtb.WebDisableRedirections = False
    qtb.Refresh BackgroundQuery:=False
  Next i
  MsgBox ("X")
  End Sub

Upvotes: 1

Views: 138

Answers (1)

Doug Glancy
Doug Glancy

Reputation: 27478

Here's what I came up with. As suggested in the comments, I create the full QueryTable the first time around. After that, I just change the connection to the next cell. The web addresses are now in each row, not every 24. The code steps through them and copies the output to a new sheet for each one. My testing involved only two sites. I don't know how many it will let you create before failing:

Sub Data()
Dim ws As Excel.Worksheet
Dim qtb As QueryTable
Dim url1 As String
Dim i As Long

Set ws = ActiveSheet 'or ws if you prefer
For i = 2 To 3 'links are in each row
    url1 = ws.Range("A" & i)
    If i = 2 Then
        Set qtb = ws.QueryTables.Add(Connection:="URL;" & url1, Destination:=ws.Range("B1"))
        With qtb
            .WebTables = "5"
            .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:=False
        End With
    Else
        qtb.Connection = "URL;" & url1
        qtb.Refresh BackgroundQuery:=False
    End If
    ws.Copy after:=ws.Parent.Worksheets(ws.Parent.Worksheets.Count)
    ActiveSheet.Columns(1).EntireColumn.Delete
Next i
End Sub

Upvotes: 1

Related Questions