AW: Nach IE.goBack "Zugriff verweigert"
01.07.2017 17:39:54
Martin
Hallo Zwenn Danke für deinen Einsatz!
Ich dachte eigentlich es wird mit der Zeit für einen Beitrag zu unübersichtlich und wollte nun das in 2 kleinere Teile unterteilen! Deswegen auch den Teil hier und auch der 2. Teil unter "Script umbau Tabelle auslesen" Dort steht mehr drinnen was ich genau möchte.
Ich habe übrigens schon einiges mehr an Script als ich hier zuletzt gepostet habe. Übrigens funktioniert mein Script bishin auf die 3. Ebene aber danach springt er in einen Zugriff verweigert.
Mein Code ist übrigens noch nicht richtig in der reinfolge aber das ist bewusst so inzwischen fürs testen. Danke übrigens nochmal das Du Dir Zeit nimmst dafür ja ich werde es in zufunkt für die Arbeit brauche möchte anhand der Daten im Excel Berechnungen über die Angebote am markt machen.
Ich habe mir übrigens gerade mal VBA beigebracht und bin kein Spezialist was das betrifft. Ich such nach Codeschnipsel im Internet und bastle mir das alles selbst zusammen.
Dafür bin ich glaube ich schon ganz schön weit gekommen. :-)
Hier nochmal mein komplettes Script:
Option Explicit
Sub TableExample()
Dim ist As Worksheet
Dim ws As Worksheet
Dim IE As Object
Dim doc As Object
Dim strURL As String
'Dim i As Long
Dim href As Object
Dim dieLinks As Object
Dim einLink As Object
Dim Zeile As Long
Dim Anbieter As Worksheet
Dim AnbieterNr As Worksheet
Dim abfAnbieter As String
Dim nextLink As Object
Dim nr As Long
strURL = "https://www.e-control.at/konsumenten/service-und-beratung/toolbox/tarifkalkulator" _
' replace with URL of your choice
Set IE = CreateObject("InternetExplorer.Application")
With IE
'Clear_Temp_Files()
'Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 8 "
'Clear_Cookies()
'Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 2"
'Clear_Form_Data()
'Shell "RunDll32.exe InetCpl.cpl,ClearMyTracksByProcess 16"
.Visible = True
'Application.Wait (Now + TimeValue("0:00:10"))
.navigate strURL
'# Navigate to one URL
Do Until .readyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
Application.Wait (Now + TimeValue("0:00:05"))
IE.document.GetElementById("_tk_portlet_WAR_tk_:tk-form-start:tk-index-search- _
form-zip").Value = _
Sheets("Tarife e-control config").Range("A1").Value
IE.document.GetElementById("_tk_portlet_WAR_tk_:tk-form-start:tk-index-search- _
form-electricity-consumption").Value = _
Sheets("Tarife e-control config").Range("A2").Value
'click the 'go' button
IE.document.GetElementById("_tk_portlet_WAR_tk_:tk-form-start:tk-index-search- _
form-search-button").Click
Do Until .readyState = 4: DoEvents: Loop
Do While .Busy: DoEvents: Loop
Application.Wait (Now + TimeValue("0:00:10"))
Set doc = IE.document.GetElementsByTagName("table")
Set dieLinks = IE.document.all.Item(Zeile).document.Links
Set ws = Sheets("einLink")
Set ist = Sheets("Info")
Set Anbieter = Sheets("Stocks")
nr = 24
'Set AnbieterNr = Sheets("Stocks").Cells(nr, 3)
abfAnbieter = Anbieter.Cells(nr, 3)
'For einLink = dieLinks To IE.document.all.Item(Zeile).document.Links
For Each einLink In dieLinks
Zeile = Zeile + 1
'Stop
'Schau dir jetzt im Lokalfenster die Eigenschaften von einLink an.
'Da gibt es so allerhand was du auswerten kannst.
'If Zeile = 803 Then
nr = nr
If einLink.innertext = abfAnbieter Then
Stop
ist.Cells(Zeile, 1) = einLink.href
ist.Cells(Zeile, 2) = "'" & IE.document.all.Item(Zeile).outertext
nr = nr + 1
abfAnbieter = Anbieter.Cells(nr, 3)
einLink.Click
Application.Wait (Now + TimeValue("0:00:10"))
Set doc = IE.document.GetElementsByTagName("table")
Dim rng As Range
Dim tbl As Object
Dim rw As Object
Dim cl As Object
Dim tabno As Long
Dim nextrow As Long
Dim i As Long
Dim xl As String
Dim y As Integer
Set ws = Sheets("detail")
For Each tbl In doc
tabno = tabno + 1
nextrow = nextrow + 1
Set rng = ws.Range("B" & nextrow)
rng.Offset(, -1) = "Table " & tabno
For Each rw In tbl.Rows
For Each cl In rw.Cells
rng.Value = cl.innertext
Set rng = rng.Offset(, 1)
i = i + 1
Next cl
nextrow = nextrow + 1
Set rng = rng.Offset(1, -i)
i = 0
Next rw
Next tbl
ws.Cells.ClearFormats
Application.Wait (Now + TimeValue("0:00:10"))
IE.GoBack
Application.Wait (Now + TimeValue("0:00:20"))
'ReDim einLink As Object
Else
ws.Cells(Zeile, 1) = einLink.href
ws.Cells(Zeile, 2) = "'" & einLink.outertext
End If
'End If
Next
'.Quit
'For Each href In IE.document.GetElementsByTagName("a")
'For i = 1 To IE.document.all.Length
'If IE.document.all.Item(i).href = "https://www.e-control.at/konsumenten/service-und- _
beratung/toolbox/tarifkalkulator?p_p_id=tk_portlet_WAR_tk&p_p_lifecycle=1&p_p_state=normal&p_p_mode=view&p_p_col_id=column-1&p_p_col_count=1&_tk_portlet_WAR_tk__facesViewIdRender=%2FsearchResult.xhtml#" Then
'IE.document.all.Item(i).Click
'While IE.Busy
'DoEvents
'Wend
'Do Until IE.readyState = READYSTATE_COMPLETE
'DoEvents
'Loop
'Exit For
'End If
'End If
'Next i
'Next href
FindAllLinks doc, IE
'GetAllTables doc
End With
End Sub
Sub FindAllLinks(doc As Object, IE As Object)
Dim ws As Worksheet
Dim dieLinks As Object
Dim einLink As Object
Dim tbl As Object
Dim L As Long
Dim Zeile As Long
Dim tblanz As Long
'Set IE = CreateObject("InternetExplorer.application")
'Set tblanz = doc.all.Length
Set dieLinks = doc.Item(L).document.Links
Set ws = Sheets("einLink")
For Each einLink In dieLinks
Zeile = Zeile + 1
'Stop
'Schau dir jetzt im Lokalfenster die Eigenschaften von einLink an.
'Da gibt es so allerhand was du auswerten kannst.
ws.Cells(Zeile, 1) = einLink.href
ws.Cells(Zeile, 2) = "'" & einLink.outertext
'For Zeile = 1 To einLink.document.all.Length
'Set .document.all.Item(Zeile) = einLink.document.all.Item(B)
'If einLink.document.all.Item(Zeile).outertext = "Verbund AG" Then
'IE.document.all.Item(Zeile).Click
'While IE.Busy
'DoEvents
'Wend
'Do Until IE.readyState = READYSTATE_COMPLETE
'DoEvents
'Loop
'Exit For
'End If
Next einLink
'Exit For
GetAllTables doc
'End With
End Sub
Sub GetAllTables(doc As Object)
' get all the tables from a webpage document, doc, and put them in a new worksheet
Dim ws As Worksheet
Dim rng As Range
Dim tbl As Object
Dim rw As Object
Dim cl As Object
Dim tabno As Long
Dim nextrow As Long
Dim i As Long
Dim xl As String
Dim y As Integer
Set ws = Sheets("Stocks")
For Each tbl In doc
tabno = tabno + 1
nextrow = nextrow + 1
Set rng = ws.Range("B" & nextrow)
rng.Offset(, -1) = "Table " & tabno
For Each rw In tbl.Rows
For Each cl In rw.Cells
rng.Value = cl.innertext
Set rng = rng.Offset(, 1)
i = i + 1
Next cl
nextrow = nextrow + 1
Set rng = rng.Offset(1, -i)
i = 0
Next rw
Next tbl
ws.Cells.ClearFormats
Zeilenumbruch_entfernen ws
End Sub
Sub Zeilenumbruch_entfernen(ws)
Dim Regex As Object
Dim meAr()
Dim nCount&, MaxRow&, MaxColumn, lngTeil&, lngStep&, i
Dim rngBereich As Range
Set Regex = CreateObject("Vbscript.Regexp")
With ws
MaxRow = .Cells(.Rows.Count, 1).End(xlUp).Row
MaxColumn = ActiveCell.SpecialCells(xlLastCell).Column
'MsgBox MaxColumn
Set rngBereich = .UsedRange
lngStep = (MaxRow - 1) / 5
With Regex
.MultiLine = True
.Pattern = "\n"
.Global = True
End With
For i = 1 To MaxColumn
For lngTeil = 1 To MaxRow - 1 Step lngStep
meAr = .Range(rngBereich(lngTeil, i), rngBereich(lngTeil + lngStep - 1, i)).Value2
For nCount = 1 To UBound(meAr)
'ersetze Zeilenumbruch durch nichts oder ein anderes Zeichen
'meAr(nCount, 1) = Regex.Replace(meAr(nCount, 1), "^")
meAr(nCount, 1) = Regex.Replace(meAr(nCount, 1), "")
Next nCount
rngBereich(lngTeil, i).Resize(UBound(meAr)) = meAr
Erase meAr
Next lngTeil
Next i
End With
ZahlenRaus ws
End Sub
Sub ZahlenRaus(ws)
Dim lZeile As Long
Dim iLaenge As Integer
Dim sZeichen As String
Dim sNeuwert As String
Dim s As String
With ws ' den Tabellenblattnamen ggf. anpassen !
For lZeile = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
's = .Range("c" & lZeile).Value
'If s = Mid(s, Len(s) - 6, 6) = vbCrLf Then
' s = Mid(s, 0, Len(s) - 2)
'End If
sNeuwert = ""
For iLaenge = 1 To Len(.Range("C" & lZeile).Value)
sZeichen = Mid(.Range("c" & lZeile).Value, iLaenge, 1)
If Not IsNumeric(sZeichen) Then
sNeuwert = sNeuwert & sZeichen
End If
Next iLaenge
.Range("c" & lZeile).Value = Replace(sNeuwert, ",%", "")
'.Range("c" & lZeile).Value = Replace(sNeuwert, ";%", "")
'.UsedRange.Replace What:="%", Replacement:="", LookAt:=xlWhole
s = .Range("c" & lZeile).Value
.Range("c" & lZeile).Value = VBA.Replace(s, Chr(13), "")
s = .Range("c" & lZeile).Value
'.Range("c" & lZeile).Value = VBA.Replace(s, Chr(32), "")
Next lZeile
End With
TrimmenVonWerten ws
End Sub
Sub TrimmenVonWerten(ws)
Dim Bereich As Range
Dim Zeilemax As Long
Dim zelle As Range
With ws
Zeilemax = .UsedRange.Rows.Count
Set Bereich = .Range("c1:B" & Zeilemax)
For Each zelle In Bereich
If IsError(zelle.Value) = False Then
zelle.Value = RTrim(zelle.Text)
'zelle.Value = Replace(zelle.Value, Chr(32), "")
End If
Next zelle
End With
End Sub