Avatar billede chicoboy Novice
23. november 2012 - 20:41 Der er 11 kommentarer og
1 løsning

Makro hente data fra internet

I Ark 1 vil jeg i celle A1 indsætte data fra internet.
På Ark 2 i celle A1 står den url fra det sted der skal hentes data.

Jeg har indspillet en makro som virker fint til ovenstående.

Sub test2()
'
' test2 Makro
'

'
    Sheets("Ark2").Select
    ActiveCell.FormulaR1C1 = _
        "http://statletik.dk/rangliste.php?sex=12&underdisc=&event=lsz_m&year=2012&button=Find+liste"
    Sheets("Ark1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://statletik.dk/rangliste.php?sex=12&underdisc=&event=lsz_m&year=2012&button=Find+liste" _
        , Destination:=Range("$A$1"))
        .Name = _
        "rangliste.php?sex=12&underdisc=&event=lsz_m&year=2012&button=Find+liste_2"
        .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
End Sub

Jeg har følgende problemer/ønsker:

1: Hvis jeg ændrer url'en i ark2 celle A1 - så  er det stadig de samme data der hentes og ikke de nye - det skyldes selvfølgelig at makroen ikke henter indholdet fra A1, men blot under indspildningen er blevet statisk - hvordan får jeg den til at hente urlen fra Ark2 A1?

2: Jeg vil gerne tilføje url'er i Ark 2 kolonne A - hvordan får jeg så makroen til at hente url'en fra A1 indsætte data - hente url'en i A2 - indsætte disse data under dem der er hentet osv?
Avatar billede tbak Nybegynder
24. november 2012 - 16:57 #1
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?
Avatar billede chicoboy Novice
24. november 2012 - 17:56 #2
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
Avatar billede chicoboy Novice
24. november 2012 - 17:57 #3
hov det skulle have været et svar...men blot kommentar
Avatar billede chicoboy Novice
24. november 2012 - 17:58 #4
hov det skulle IKKE have været et svar...men blot kommentar
Avatar billede tbak Nybegynder
25. november 2012 - 07:22 #5
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
Avatar billede chicoboy Novice
25. november 2012 - 14:32 #6
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.
Avatar billede tbak Nybegynder
28. november 2012 - 17:06 #7
Ups, du skal lige slette disse to linier fra Sub MakeList
    Sheets("Ark2").Select
    url = Cells(1, 1).Value
Avatar billede chicoboy Novice
30. november 2012 - 23:15 #8
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.
Avatar billede chicoboy Novice
30. november 2012 - 23:38 #9
ø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
Avatar billede tbak Nybegynder
01. december 2012 - 17:18 #10
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
Avatar billede chicoboy Novice
01. december 2012 - 20:12 #11
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
Avatar billede chicoboy Novice
01. december 2012 - 20:15 #12
point for tillægsspørgssmål

http://www.eksperten.dk/spm/973058
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester