Avatar billede chicoboy Novice
01. december 2012 - 20:14 Der er 3 kommentarer og
1 løsning

Hente autodata vil Url

Dette indlæg er kun for at kunne give tbak point.

Tillægsspørgsmål til denne

http://www.eksperten.dk/spm/972766#reply_8004853
Avatar billede tbak Nybegynder
02. december 2012 - 19:46 #1
Det undrer mig lidt at fejlhåndteringen ikke virker. Prøv at sende et link til en tom liste.
Avatar billede chicoboy Novice
02. december 2012 - 19:59 #2
Avatar billede tbak Nybegynder
03. december 2012 - 10:08 #3
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
Avatar billede chicoboy Novice
03. december 2012 - 21:14 #4
Perfekt - det virker - Tusind tak for hjælpen!
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