Makro og VBA - Export af Query data til Excel

Export af Query data til Excel

Udskrevet fra: Dansk Regneark Forum
Kategori: Hjælp til regneark.
Forum navn: Makro og VBA
Forum beskrivelse: Hjælp til Makroer og VBA-programmering
Web-adresse: https://forum.excel-regneark.dk/forum_posts.asp?TID=890
Udskrevet den: 18.Maj.2024 kl. 09:12

Emne: Export af Query data til Excel

Besked fra: Ronni89
Emne: Export af Query data til Excel
Posteringsdato: 15.Sep.2012 kl. 12:54

Hej Alle.

Jeg skal hente en data tabel fra en webside med login og password.

http://www.installationsblanket.dk/logon.asp - http://www.installationsblanket.dk/logon.asp

Jeg kommer forbi denne side og næste side er:

http://www.installationsblanket.dk/selskab/500.asp - http://www.installationsblanket.dk/selskab/500.asp

Det er dog ikke på denne side jeg skal hente tabellen, og muligvis derfor får jeg fejlmeddelelsen Run-time error 1004, application-defined ot object-defines error. Jeg skal klikke på "et link" her for at navigere til:

http://www.installationsblanket.dk/selskab/600.asp - http://www.installationsblanket.dk/selskab/600.asp

som er siden jeg skal hente tabellen fra.

Kan nogle hjælpe mig med at navigere videre på siden, eller se hvad der ellers er galt? det er som om jeg mangler at kunne sætte et step ind.

Sub Basic_Web_Query()

Set ie = CreateObject("InternetExplorer.Application")

With ie

.Visible = True

.navigate "http://www.installationsblanket.dk/logon.asp"

Do Until .readyState = READYSTATE_COMPLETE

DoEvents

Loop

.document.all.Item("BRUGERNAVN").Value = "Bruger"

.document.all.Item("ADGANGSKODE").Value = "Adgangskode"

.document.forms(0).submit

End With

With ActiveSheet.QueryTables.Add(Connection:= _

"URL;http://www.installationsblanket.dk/selskab/600-main.asp", Destination:= _

Range("$A$1"))

.Name = "600-main"

.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

End Sub

Bruger og adgangskode er sløret.

På forhånd tak.

Svar:

Besked fra: Ronni89
Posteringsdato: 15.Sep.2012 kl. 17:29

Nu er jeg kommet en del videre med det, med hjælp fra http://www.dailydoseofexcel.com/archives/2011/03/08/get-data-from-website-that-requires-a-login/ - http://www.dailydoseofexcel.com/archives/2011/03/08/get-data-from-website-that-requires-a-login/

Jeg har dog et problem, da der ingen Tabel ID er på denne side. Kan jeg sætte hele siden ind på nogen måde?

Sub GetTable()

Dim ieApp As InternetExplorer

Dim ieDoc As Object

Dim ieTable As Object

Dim clip As DataObject

'create a new instance of ie

Set ieApp = New InternetExplorer

'you don’t need this, but it’s good for debugging

ieApp.Visible = True

'assume we’re not logged in and just go directly to the login page

ieApp.navigate "http://www.installationsblanket.dk/Logon.asp"

Do While ieApp.Busy: DoEvents: Loop

Do Until ieApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop

Set ieDoc = ieApp.document

'fill in the login form – View Source from your browser to get the control names

With ieDoc.forms(0)

.Brugernavn.Value = "***"

.Adgangskode.Value = "***"

.submit

End With

Do While ieApp.Busy: DoEvents: Loop

Do Until ieApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop

'now that we’re in, go to the page we want

ieApp.navigate "http://www.installationsblanket.dk/selskab/600.asp"

Do While ieApp.Busy: DoEvents: Loop

Do Until ieApp.readyState = READYSTATE_COMPLETE: DoEvents: Loop

'get the table based on the table’s id

Set ieDoc = ieApp.document

Set ieTable = ieDoc.all.Item("Bottom")

'copy the tables html to the clipboard and paste to teh sheet

If Not ieTable Is Nothing Then

Set clip = New DataObject

clip.SetText "<html>" & MieTable.outerHTML & "</html>"

clip.PutInClipboard

Sheet1.Select

Sheet1.Range("A1").Select

Sheet1.PasteSpecial "Unicode Text"

End If

'close 'er up

ieApp.Quit

Set ieApp = Nothing

End Sub