Makro hente data fra internet

Svaret på 1:
Udskift disse linier
    Sheets("Ark2").Select
    ActiveCell.FormulaR1C1 = _
        "http://statletik.dk/ (...)
    Sheets("Ark1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://statletik.dk/ (...) _

med

    Sheets("Ark2").Select
    URL = Cells(1,1).value
    Sheets("Ark1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & URL _

og lad resten af koden stå.

spm 2:
Er det meningen at det samme slags liste, blot med forskellige filtre, du vil indsætte URL'er for i kolonne a i ark2?

tak - det løste problemet med den statiske url.

Ift spm 2 - så ønsker jeg en løkke som kører alle url'en igennem som står i søjle A i ark 2. Data er samme type - fx længdespring 2012, 2011, 2010, højdespring 2012, 2011, osv.

(data er ranglister der hentes herfra http://statletik.dk/rangliste.php?sex=12&underdisc=&event=80_m&year=2012&button=Find+liste)

Data der hentes skal tilføjes i ark 1 efter allerede hentet data

hov det skulle have været et svar...men blot kommentar

hov det skulle IKKE have været et svar...men blot kommentar

Prøv at teste denne kode:

Sub test2()
    Sheets("Ark2").Select
    r = 1
    d = "A1"
    While Cells(r, 1).Value <> ""
        url = Cells(r, 1).Value
        MakeList url, d
        r = r + 1
        Sheets("Ark1").Select
        d = "A" & ActiveCell.Row
        Sheets("Ark2").Select
    Wend
End Sub


Private Sub MakeList(ByVal url As String, ByVal destination As String)
    Sheets("Ark2").Select
    url = Cells(1, 1).Value
    Sheets("Ark1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;" & url _
        , destination:=Range(destination))
        .Name = _
        "List" & 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
   
    Selection.End(xlDown).Select
    Range("A" & ActiveCell.Row + 1).Select

End Sub

Det er tæt på at virke. Men løkken virker ikke helt.

Lad os sige der i ark2 står x url'er i celle A1:Ax. Så hentes data fra celle A1 x gange. Her skulle den i stedet hente data fra url'en i A1 herefter A2 osv indtil Ax.

Ups, du skal lige slette disse to linier fra Sub MakeList
    Sheets("Ark2").Select
    url = Cells(1, 1).Value

Tak igen - det virker.

Tillægsspørgsmål: (opretter gerne pointspørgsmål til 60 til dig)

Fra url'en hentes data fra internettet. Jeg vil gerne have tilføjet data som jeg skriver i søjle B og C i ark 2 ud for url'en

fx - ark2

A1: URL  B1: Længdespring C1: Spring
A2: URL  B2: Højdespring  C2: Spring

urlen i A1 henter x antal rækker med data - disse data tilføjes to kolonner med det der står i hhv. B1 og C1 osv.

øv - så var der alligevel en fejl. Hvis urlen peger hen til en liste som ikke har nogle data, så fås fejlen

Runtime error 1004
Method 'range' of object global failed

Hej chicoboy
Her er en løsning både til tråd #8 og #9
Erstat all den tidligere kode med nedenstående

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
   
    Selection.End(xlDown).Select
    Range("A" & ActiveCell.Row + 1).Select
    endRow = ActiveCell.Row - 1
    KopierFraArk1 startRow, endRow, kolonneB, kolonneC
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

Nu kopieres data fra celle B og C som ønsket - supergodt!

Fejlhåndteringen virker ikke - hvis urlen peger hen på en tom liste, så sker der fejl

point for tillægsspørgssmål

http://www.eksperten.dk/spm/973058