Hente autodata vil Url

Det undrer mig lidt at fejlhåndteringen ikke virker. Prøv at sende et link til en tom liste.

Ved disse tre link er der data i nr. 1+3 - mens 2 er tom

http://statletik.dk/rangliste.php?sex=25&underdisc=&event=100_m_m&year=2012&button=Find+liste
http://statletik.dk/rangliste.php?sex=25&underdisc=&event=80_m_m&year=2012&button=Find+liste
http://statletik.dk/rangliste.php?sex=25&underdisc=&event=1500_m_m&year=2012&button=Find+liste


Data fra første link hentet - herefter hoppes ned til række 1.048.576 - formentlig sidste række

Dette skulle afhjælpe fejlen her er hele koden igen:

Option Explicit
Sub test2()
    Dim url, r, d, b, c
    Sheets("Ark2").Select
    r = 1
    d = "A1"
    While Cells(r, 1).Value <> ""
        url = Cells(r, 1).Value
        b = Cells(r, 2).Value
        c = Cells(r, 3).Value
        MakeList url, d, b, c
        r = r + 1
        Sheets("Ark1").Select
        d = "A" & ActiveCell.Row
        Sheets("Ark2").Select
    Wend
    Sheets("Ark1").Select
    Cells.EntireColumn.AutoFit
End Sub


Private Sub MakeList(ByVal url As String, ByVal destination As String, ByVal kolonneB, ByVal kolonneC)
    Dim startRow, endRow
    On Error GoTo errHandler
    Sheets("Ark1").Select
    startRow = ActiveCell.Row + 1
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & url _
        , destination:=Range(destination))
        .Name = _
        "List" & ActiveCell.Row
        .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 = "4"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
   
    If Cells(ActiveCell.Row + 1, 1).Value <> "" Then
        Selection.End(xlDown).Select
        Range("A" & ActiveCell.Row + 1).Select
        endRow = ActiveCell.Row - 1
        KopierFraArk1 startRow, endRow, kolonneB, kolonneC
    Else
        Range("A" & ActiveCell.Row + 1).Select
    End If

errHandler:

End Sub

Private Sub KopierFraArk1(ByVal startRow, ByVal endRow, ByVal kolonneB, ByVal kolonneC)
    Dim i
    For i = startRow To endRow
        Cells(i, 7).Formula = kolonneB
        Cells(i, 8).Formula = kolonneB
    Next i
End Sub

Perfekt - det virker - Tusind tak for hjælpen!